From bcbf441e09fb502cf64924ff2530fa144bdf52c5 Mon Sep 17 00:00:00 2001 From: Andreas Brachold Date: Mon, 13 Aug 2007 18:41:27 +0000 Subject: * Move files to trunk --- lib/Class/MakeMethods/Template.pm | 1255 +++++++++++++++++++++++++++++++++++++ 1 file changed, 1255 insertions(+) create mode 100644 lib/Class/MakeMethods/Template.pm (limited to 'lib/Class/MakeMethods/Template.pm') diff --git a/lib/Class/MakeMethods/Template.pm b/lib/Class/MakeMethods/Template.pm new file mode 100644 index 0000000..d5cd8f5 --- /dev/null +++ b/lib/Class/MakeMethods/Template.pm @@ -0,0 +1,1255 @@ +package Class::MakeMethods::Template; + +use strict; +use Carp; + +use Class::MakeMethods '-isasubclass'; + +use vars qw( $VERSION ); +$VERSION = 1.008; + +sub _diagnostic { &Class::MakeMethods::_diagnostic } + +######################################################################## +### TEMPLATE LOOKUP AND CACHING: named_method(), _definition() +######################################################################## + +use vars qw( %TemplateCache ); + +# @results = $class->named_method( $name, @arguments ); +sub named_method { + my $class = shift; + my $name = shift; + + # Support direct access to cached Template information + if (exists $TemplateCache{"$class\::$name"}) { + return $TemplateCache{"$class\::$name"}; + } + + my @results = $class->$name( @_ ); + + if ( scalar @results == 1 and ref $results[0] eq 'HASH' ) { + # If this is a hash-definition format, cache the results for speed. + my $def = $results[0]; + $TemplateCache{"$class\::$name"} = $def; + _expand_definition($class, $name, $def); + return $def; + } + + return wantarray ? @results : $results[0]; +} + +# $mm_def = _definition( $class, $target ); +sub _definition { + my ($class, $target) = @_; + + while ( ! ref $target ) { + $target =~ s/\s.*//; + + # If method name contains a colon or double colon, call the method on the + # indicated class. + my $call_class = ( ( $target =~ s/^(.*)\:{1,2}// ) + ? Class::MakeMethods::_find_subclass($class, $1) : $class ); + $target = $call_class->named_method( $target ); + } + _diagnostic('mmdef_not_interpretable', $target) + unless ( ref($target) eq 'HASH' or ref($target) eq __PACKAGE__ ); + + return $target; +} + +######################################################################## +### TEMPLATE INTERNALS: _expand_definition() +######################################################################## + +sub _expand_definition { + my ($class, $name, $mm_def) = @_; + + return $mm_def if $mm_def->{'-parsed'}; + + $mm_def->{'template_class'} = $class; + $mm_def->{'template_name'} = $name; + + # Allow definitions to import values from each other. + my $importer; + foreach $importer ( qw( interface params behavior code_expr modifier ) ) { + my $rules = $mm_def->{$importer}->{'-import'} || $mm_def->{'-import'}; + my @rules = ( ref $rules eq 'HASH' ? %$rules : ref $rules eq 'ARRAY' ? @$rules : () ); + unshift @rules, '::' . $class . ':generic' => '*' if $class->can('generic'); + while ( + my ($source, $names) = splice @rules, 0, 2 + ) { + my $mmi = _definition($class, $source); + foreach ( ( $names eq '*' ) ? keys %{ $mmi->{$importer} } + : ( ref $names ) ? @{ $names } : ( $names ) ) { + my $current = $mm_def->{$importer}{$_}; + my $import = $mmi->{$importer}{$_}; + if ( ! $current ) { + $mm_def->{$importer}{$_} = $import; + } elsif ( ref($current) eq 'ARRAY' ) { + my @imports = ref($import) ? @$import : $import; + foreach my $imp ( @imports ) { + push @$current, $imp unless ( grep { $_ eq $imp } @$current ); + } + } + } + } + delete $mm_def->{$importer}->{'-import'}; + } + delete $mm_def->{'-import'}; + + _describe_definition( $mm_def ) if $Class::MakeMethods::CONTEXT{Debug}; + + + $mm_def->{'-parsed'} = "$_[1]"; + + bless $mm_def, __PACKAGE__; +} + +sub _describe_definition { + my $mm_def = shift; + + my $def_type = "$mm_def->{template_class}:$mm_def->{template_name}"; + warn "----\nMethods info for $def_type:\n"; + if ( $mm_def->{interface} ) { + warn join '', "Templates: \n", map { + " $_: " . _describe_value($mm_def->{interface}{$_}) . "\n" + } keys %{$mm_def->{interface}}; + } + if ( $mm_def->{modifier} ) { + warn join '', "Modifiers: \n", map { + " $_: " . _describe_value($mm_def->{modifier}{$_}) . "\n" + } keys %{$mm_def->{modifier}}; + } +} + +sub _describe_value { + my $value = $_[0]; + ref($value) eq 'ARRAY' ? join(', ', @$value) : + ref($value) eq 'HASH' ? join(', ', %$value) : + "$value"; +} + +######################################################################## +### METHOD GENERATION: make_methods() +######################################################################## + +sub make_methods { + my $mm_def = shift; + + return unless ( scalar @_ ); + + # Select default interface and initial method parameters + my $defaults = { %{ ( $mm_def->{'params'} ||= {} ) } }; + $defaults->{'interface'} ||= $mm_def->{'interface'}{'-default'} || 'default'; + $defaults->{'target_class'} = $mm_def->_context('TargetClass'); + $defaults->{'template_class'} = $mm_def->{'template_class'}; + $defaults->{'template_name'} = $mm_def->{'template_name'}; + + my %interface_cache; + + # Our return value is the accumulated list of method-name => method-sub pairs + my @methods; + + while (scalar @_) { + + ### PARSING ### Requires: $mm_def, $defaults, @_ + + my $m_name = shift @_; + _diagnostic('make_empty') unless ( defined $m_name and length $m_name ); + + # Normalize: If we've got an array of names, replace it with those names + if ( ref $m_name eq 'ARRAY' ) { + my @items = @{ $m_name }; + # If array is followed by a params hash, each one gets the same params + if ( scalar @_ and ref $_[0] eq 'HASH' and ! exists $_[0]->{'name'} ) { + my $params = shift; + @items = map { $_, $params } @items + } + unshift @_, @items; + next; + } + + # Parse interfaces, modifiers and parameters + if ( $m_name =~ s/^-// ) { + if ( $m_name !~ s/^-// ) { + # -param => value + $defaults->{$m_name} = shift @_; + } else { + if ( $m_name eq '' ) { + # '--' => { param => value ... } + %$defaults = ( %$defaults, %{ shift @_ } ); + + } elsif ( exists $mm_def->{'interface'}{$m_name} ) { + # --interface + $defaults->{'interface'} = $m_name; + + } elsif ( exists $mm_def->{'modifier'}{$m_name} ) { + # --modifier + $defaults->{'modifier'} .= + ( $defaults->{'modifier'} ? ' ' : '' ) . "-$m_name"; + + } elsif ( exists $mm_def->{'behavior'}{$m_name} ) { + # --behavior as shortcut for single-method interface + $defaults->{'interface'} = $m_name; + + } else { + _diagnostic('make_bad_modifier', $mm_def->{'name'}, "--$m_name"); + } + } + next; + } + + # Make a new meta-method hash + my $m_info; + + # Parse string, string-then-hash, and hash-only meta-method parameters + if ( ! ref $m_name ) { + if ( scalar @_ and ref $_[0] eq 'HASH' and ! exists $_[0]->{'name'} ) { + %$m_info = ( 'name' => $m_name, %{ shift @_ } ); + } else { + $m_info = { 'name' => $m_name }; + } + + } elsif ( ref $m_name eq 'HASH' ) { + unless ( exists $m_name->{'name'} and length $m_name->{'name'} ) { + _diagnostic('make_noname'); + } + $m_info = { %$m_name }; + + } else { + _diagnostic('make_unsupported', $m_name); + } + _diagnostic('debug_declaration', join(', ', map { defined $_ ? $_ : '(undef)' } %$m_info) ); + + ### INITIALIZATION ### Requires: $mm_def, $defaults, $m_info + + my $interface = ( + $interface_cache{ $m_info->{'interface'} || $defaults->{'interface'} } + ||= _interpret_interface( $mm_def, $m_info->{'interface'} || $defaults->{'interface'} ) + ); + %$m_info = ( + %$defaults, + ( $interface->{-params} ? %{$interface->{-params}} : () ), + %$m_info + ); + + + # warn "Actual: " . Dumper( $m_info ); + + + # Expand * and *{...} strings. + foreach (grep defined $m_info->{$_}, keys %$m_info) { + $m_info->{$_} =~ s/\*(?:\{([^\}]+)?\})?/ $m_info->{ $1 || 'name' } /ge + } + if ( $m_info->{'modifier'} and $mm_def->{modifier}{-folding} ) { + $m_info->{'modifier'} = _fold_modifiers( $m_info->{'modifier'}, + $mm_def->{modifier}{-folding} ) + } + + ### METHOD GENERATION ### Requires: $mm_def, $interface, $m_info + + # If the MM def provides an initialization "-init" call, run it. + if ( local $_ = $mm_def->{'behavior'}->{'-init'} ) { + push @methods, map $_->( $m_info ), (ref($_) eq 'ARRAY') ? @$_ : $_; + } + # Build Methods + for ( grep { /^[^-]/ } keys %$interface ) { + my $function_name = $_; + $function_name =~ s/\*/$m_info->{'name'}/g; + + my $behavior = $interface->{$_}; + + # Fold in additional modifiers + if ( $m_info->{'modifier'} ) { + if ( $behavior =~ /^\-/ and $mm_def->{modifier}{-folding} ) { + $behavior = $m_info->{'modifier'} = + _fold_modifiers( "$m_info->{'modifier'} $behavior", + $mm_def->{modifier}{-folding} ) + } else { + $behavior = "$m_info->{'modifier'} $behavior"; + } + } + + my $builder = + ( $mm_def->{'-behavior_cache'}{$behavior} ) ? + $mm_def->{'-behavior_cache'}{$behavior} : + ( ref($mm_def->{'behavior'}{$behavior}) eq 'CODE' ) ? + $mm_def->{'behavior'}{$behavior} : +_behavior_builder( $mm_def, $behavior, $m_info ); + + my $method = &$builder( $m_info ); + + _diagnostic('debug_make_behave', $behavior, $function_name, $method); + push @methods, ($function_name => $method) if ($method); + } + + # If the MM def provides a "-subs" call, for forwarding and other + # miscelaneous "subsidiary" or "contained" methods, run it. + if ( my $subs = $mm_def->{'behavior'}->{'-subs'} ) { + my @subs = (ref($subs) eq 'ARRAY') ? @$subs : $subs; + foreach my $sub ( @subs ) { + my @results = $sub->($m_info); + if ( scalar @results == 1 and ref($results[0]) eq 'HASH' ) { + # If it returns a hash of helper method types, check the method info + # for any matching names and call the corresponding method generator. + my $types = shift @results; + foreach my $type ( keys %$types ) { + my $names = $m_info->{$type} or next; + my @names = ref($names) eq 'ARRAY' ? @$names : split(' ', $names); + my $generator = $types->{$type}; + push @results, map { $_ => &$generator($m_info, $_) } @names; + } + } + push @methods, @results; + } + } + + # If the MM def provides a "-register" call, for registering meta-method + # information for run-time access, run it. + if ( local $_ = $mm_def->{'behavior'}->{'-register'} ) { + push @methods, map $_->( $m_info ), (ref($_) eq 'ARRAY') ? @$_ : $_; + } + } + + return @methods; +} + +# I'd like for the make_methods() sub to be simpler, and to take advantage +# of the standard _get_declarations parsing provided by the superclass. +# Sadly the below doesn't work, due to a few order-of-operations peculiarities +# of parsing interfaces and modifiers, and their associated default paramters. +# Perhaps it might work if the processing of --options could be overridden with +# a callback sub, so that interfaces and their params can be parsed in order. +sub _x_get_declarations { + my $mm_def = shift; + + my @declarations = $mm_def::SUPER->_get_declarations( @_ ); + + # use Data::Dumper; + # warn "In: " . Dumper( \@_ ); + # warn "Auto: " . Dumper( \@declarations ); + + my %interface_cache; + + while (scalar @declarations) { + + my $m_info = shift @declarations; + + # Parse interfaces and modifiers + my @specials = grep $_, split '--', ( delete $m_info->{'--'} || '' ); + foreach my $special ( @specials ) { + if ( exists $mm_def->{'interface'}{$special} ) { + # --interface + $m_info->{'interface'} = $special; + + } elsif ( exists $mm_def->{'modifier'}{$special} ) { + # --modifier + $m_info->{'modifier'} .= + ( $m_info->{'modifier'} ? ' ' : '' ) . "-$special"; + + } elsif ( exists $mm_def->{'behavior'}{$special} ) { + # --behavior as shortcut for single-method interface + $m_info->{'interface'} = $special; + + } else { + _diagnostic('make_bad_modifier', $mm_def->{'name'}, "--$special"); + } + } + + my $interface = ( + $interface_cache{ $m_info->{'interface'} } + ||= _interpret_interface( $mm_def, $m_info->{'interface'} ) + ); + $m_info = { %$m_info, %{$interface->{-params}} } if $interface->{-params}; + + _diagnostic('debug_declaration', join(', ', map { defined $_ ? $_ : '(undef)' } %$m_info) ); + + # warn "Updated: " . Dumper( $m_info ); + } +} + +######################################################################## +### TEMPLATES: _interpret_interface() +######################################################################## + +sub _interpret_interface { + my ($mm_def, $interface) = @_; + + if ( ref $interface eq 'HASH' ) { + return $interface if exists $interface->{'-parsed'}; + } + elsif ( ! defined $interface or ! length $interface ) { + _diagnostic('tmpl_empty'); + + } + elsif ( ! ref $interface ) { + if ( exists $mm_def->{'interface'}{ $interface } ) { + if ( ! ref $mm_def->{'interface'}{ $interface } ) { + $mm_def->{'interface'}{ $interface } = + { '*' => $mm_def->{'interface'}{ $interface } }; + } + } elsif ( exists $mm_def->{'behavior'}{ $interface } ) { + $mm_def->{'interface'}{ $interface } = { '*' => $interface }; + } else { + _diagnostic('tmpl_unkown', $interface); + } + $interface = $mm_def->{'interface'}{ $interface }; + + return $interface if exists $interface->{'-parsed'}; + } + elsif ( ref $interface ne 'HASH' ) { + _diagnostic('tmpl_unsupported', $interface); + } + + $interface->{'-parsed'} = "$_[1]"; + + # Allow interface inheritance via -base specification + if ( $interface->{'-base'} ) { + for ( split ' ', $interface->{'-base'} ) { + my $base = _interpret_interface( $mm_def, $_ ); + %$interface = ( %$base, %$interface ); + } + delete $interface->{'-base'}; + } + + for (keys %$interface) { + # Remove empty/undefined items. + unless ( defined $interface->{$_} and length $interface->{$_} ) { + delete $interface->{$_}; + next; + } + } + # _diagnostic('debug_interface', $_[1], join(', ', %$interface )); + + return $interface; +} + +######################################################################## +### BEHAVIORS AND MODIFIERS: _fold_modifiers(), _behavior_builder() +######################################################################## + +sub _fold_modifiers { + my $spec = shift; + my $rules = shift; + my %rules = @$rules; + + # Longest first, to prevent over-eager matching. + my $rule = join '|', map "\Q$_\E", + sort { length($b) <=> length($a) } keys %rules; + # Match repeatedly from the front. + 1 while ( $spec =~ s/($rule)/$rules{$1}/ ); + $spec =~ s/(^|\s)\s/$1/g; + return $spec; +} + +sub _behavior_builder { + my ( $mm_def, $behavior, $m_info ) = @_; + + # We're going to have to do some extra work here, so we'll cache the result + my $builder; + + # Separate the modifiers + my $core_behavior = $behavior; + my @modifiers; + while ( $core_behavior =~ s/\-(\w+)\s// ) { push @modifiers, $1 } + + # Find either the built-in or universal behavior template + if ( $mm_def->{'behavior'}{$core_behavior} ) { + $builder = $mm_def->{'behavior'}{$core_behavior}; + } else { + my $universal = _definition('Class::MakeMethods::Template::Universal','generic'); + $builder = $universal->{'behavior'}{$core_behavior} + } + + # Otherwise we're hosed. + $builder or _diagnostic('make_bad_behavior', $m_info->{'name'}, $behavior); + + if ( ! ref $builder ) { + # If we've got a text template, pass it off for interpretation. + my $code = ( ! $Class::MakeMethods::Utility::DiskCache::DiskCacheDir ) ? + _interpret_text_builder($mm_def, $core_behavior, $builder, @modifiers) + : _disk_cache_builder($mm_def, $core_behavior, $builder, @modifiers); + + # _diagnostic('debug_eval_builder', $name, $code); + local $^W unless $Class::MakeMethods::CONTEXT{Debug}; + $builder = eval $code; + if ( $@ ) { _diagnostic('behavior_eval', $@, $code) } + unless (ref $builder eq 'CODE') { _diagnostic('behavior_eval', $@, $code) } + + } elsif ( scalar @modifiers ) { + # Can't modify code subs + _diagnostic('make_behavior_mod', join(', ', @modifiers), $core_behavior); + } + + $mm_def->{'-behavior_cache'}{$behavior} = $builder; + + return $builder; +} + +######################################################################## +### CODE EXPRESSIONS: _interpret_text_builder(), _disk_cache_builder() +######################################################################## + +sub _interpret_text_builder { + require Class::MakeMethods::Utility::TextBuilder; + + my ( $mm_def, $name, $code, @modifiers ) = @_; + + foreach ( @modifiers ) { + exists $mm_def->{'modifier'}{$_} + or _diagnostic('behavior_mod_unknown', $name, $_); + } + + my @exprs = grep { $_ } map { + $mm_def->{'modifier'}{ $_ }, + $mm_def->{'modifier'}{ "$_ $name" } || $mm_def->{'modifier'}{ "$_ *" } + } ( '-all', ( scalar(@modifiers) ? @modifiers : '-default' ) ); + + # Generic method template + push @exprs, "return sub _SUB_ATTRIBS_ { \n my \$self = shift;\n * }"; + + # Closure-generator + push @exprs, "sub { my \$m_info = \$_[0]; * }"; + + my $exprs = $mm_def->{code_expr}; + unshift @exprs, { + ( map { $_=>$exprs->{$_} } grep /^[^-]/, keys %$exprs ), + '_BEHAVIOR_{}' => $mm_def->{'behavior'}, + '_SUB_ATTRIBS_' => '', + }; + + my $result = Class::MakeMethods::Utility::TextBuilder::text_builder($code, + @exprs); + + my $modifier_string = join(' ', map "-$_", @modifiers); + my $full_name = "$name ($mm_def->{template_class} $mm_def->{template_name}" . + ( $modifier_string ? " $modifier_string" : '' ) . ")"; + + _diagnostic('debug_template_builder', $full_name, $code, $result); + + return $result; +} + +sub _disk_cache_builder { + require Class::MakeMethods::Utility::DiskCache; + my ( $mm_def, $core_behavior, $builder, @modifiers ) = @_; + + Class::MakeMethods::Utility::DiskCache::disk_cache( + "$mm_def->{template_class}::$mm_def->{template_name}", + join('.', $core_behavior, @modifiers), + \&_interpret_text_builder, ($mm_def, $core_behavior, $builder, @modifiers) + ); +} + +1; + +__END__ + + +=head1 NAME + +Class::MakeMethods::Template - Extensible code templates + + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Hash ( + 'new' => 'new', + 'string' => 'foo', + 'number' => 'bar', + ); + + my $obj = MyObject->new( foo => "Foozle", bar => 23 ); + print $obj->foo(); + $obj->bar(42); + + +=head1 MOTIVATION + +If you compare the source code of some of the closure-generating +methods provided by other subclasses of Class::MakeMethods, +such as the C accessors provided by the various Standard::* +subclasses, you will notice a fair amount of duplication. This +module provides a way of assembling common pieces of code to +facilitate support the maintenance of much larger libraries of +generated methods. + + +=head1 DESCRIPTION + +This module extends the Class::MakeMethods framework by providing +an abstract superclass for extensible code-templating method +generators. + +Common types of methods are generalized into B