Class::Methodist - define methods for instance variables in a class

Class-Methodist documentation Contained in the Class-Methodist distribution.

Index

Code Index:

NAME

Top

Class::Methodist - define methods for instance variables in a class

SYNOPSIS

Top

  package My::Shiny::New::Class;

  use Class::Methodist
  (
   scalar => 'global_config_path',
   hash => 'unique_words',
   list => 'file_names',
   object => { name => 'thing', class => 'My::Thing:Class' },
   enum => { name => 'color', domain => [ 'red', 'green', 'blue' ] },
   scalars => [ 'alpha', 'beta' ]
  );

  sub new {
    my ($class, $alpha) = @_;
    $class->beget(alpha => $alpha, beta => 42);
  }

DESCRIPTION

Top

This package creates instance variables and methods on a class for accessing and manipulating those instance variables. Class::Methodist is similar in spirit to Class::MakeMethods, but with a simpler interface and more sensible semantics.

Instance variables to be defined are given as a list of instance variable specifications (a.k.a. specification) when the module is used. A specification consists of a pair whose first element is the type of the variable (e.g., scalar, hash, list) and whose second element is the name of the variable to be defined. The latter must be a valid Perl identifier name.

For each specification, the module defines a type-specific set of methods on the calling class. The names of these methods usually include the name of the instance variable. In the following sections, we refer to the instance variable name by the generic identifier inst_var.

In your constructor you must call the beget class method to instantiate and initialize each instance of the class.

CLASS METHODS

Top

beget()

This class method instantiates and initializes an object of the class. It takes the place of an explicit call to the Perl bless function (which it invokes under the hood).

You may pass arguments to beget to initialize the new object. These arguments must appear in pairs (as for a hash initializer). The first item in each pair should be the name of an attribute defined by your use of Class::Methodist and the second item in each pair should be the value to which that attribute is initialized. Note that if you initialize list or hash attributes, you must pass the initializer value as a reference to an array or hash, respectively.

The beget method blesses the new object into the class and returns the blessed object. You can either assign the return value to a variable (often, self) for further construction, or may simply invoke beget as the final statement in your constructor, which arranges to return the newly minted object to the caller.

import()

This method satisfies the import semantics required of any module that uses Class::Methodist. It takes as arguments the list of specifications provided in the use directive in the calling module. The method defines the instance variables and their associated methods in the namespace of the calling class, also referred to as the destination class.

verify_method_not_defined($dest_class, $method)

We don't want to overwrite methods already defined in the calling class. Check whether $method is defined in the destination class. If so, throw an exception.

define_method($dest_class, $method, $sub_ref)

Define a method named $method in the destination class $dest_class to be the subroutine refererenced by $sub_ref. It is an error to define a method that already exists. This method is the business end of this module in that all the following type-specific methods invoke define_method in order to create the method(s) associated with each instance variable.

Constructor

Define a constructor in the destination class as follows:

   ctor => 'new'

The generated constructor simply blesses an anonymous hash into the destination class.

Enum

Define methods in the destination class for a scalar-valued instance variable that is constrained to take one of an enumerated series of values.

   enum => { name => 'colors',
             domain => [ qw/red green blue/ ],
             default => 'blue' }

The name and domain attributes are required. If the default attribute is provided, its value must evaluate to a member of the domain.

inst_var(...)

The method named the same as the instance variable is the setter and getter. If called with no arguments, returns the current value of the enumerated attribute. If called with an argument, the scalar is set to that value, provided the value is one of the values enumerated in the domain list. If the value is not in the domain, throws an error.

Hash

Define methods in the destination class for a hash-valued instance variable called inst_var as follows:

   hash => 'inst_var'

This specification defines the following methods in the destination class:

inst_var($key, [$value])

The method having the same name as the instance variable is the setter and getter:

   my $value = $obj->inst_var('key');
   $obj->inst_var(key => 'value');

When called with a single argument, there are two cases. First, if the argument is a hash reference, replace the contents of the hash with that of the referenced hash. Second, if it is not a hash reference, treat it as a key; the method returns the value stored under that key.

When called with more than one argument, treat the arguments as key-value pairs and store them in the hash. There must be an even number of arguments (i.e., they must be pairs). Return the value of the last pair.

inst_var_exists($key)

Method that returns whether a key exists in the hash.

   if ($obj->inst_var_exists('key')) { ... }
inst_var_keys()

Method that returns the list of keys in the hash.

   my @keys = $obj->inst_var_keys();
inst_var_values()

Method that returns the list of values in the hash.

   my @values = $obj->inst_var_values();
inst_var_clear()

Method that clears the hash.

   $obj->inst_var_clear();
inst_var_delete($key)

Delete the hash element with the given key.

   $obj->inst_var_delete($key)
inst_var_size()

Return the number of key-value pairs stored in the hash.

   my $size = inst_var_size();
inst_var_inc($key, [$n])

Add the value of $n to the value found under $key in the hash. The value of $n defaults to one, yielding a simple increment operation. Return the new value.

Hash of Lists

Define methods in the destination class for a hash-of-lists instance variable called inst_var as follows:

   hash_of_lists => 'inst_var'

This specification defines the following methods in the destination class:

inst_var(...)

The method having the same name as the instance variable is the setter and getter. Its behavior depends on the number of arguments passed to the method.

When called with no arguments, the method returns all the values stored in all the lists.

When called with one argument, it is treated as a key into the hash and returns the values stored in the list having that hash key.

The method returns a list in array context and a reference to a list in scalar context.

inst_var_push($key, @args)

Push @args on the list stored under $key.

inst_var_keys()

Return a list of all the keys in the hash.

List

Define methods in the destination class for a list-valued instance variable called inst_var as follows:

   list => 'inst_var'

This specification defines the following methods in the destination class:

inst_var(...)

The method named the same as the instance variable is the setter and getter. Its behavior depends on the number of arguments with which it is invoked.

When called with no arguments, return the contents of the list (when called in array context) or a reference to the list (when called in scalar context).

When called with one argument that is a reference to a list, replace the contents of the list with the contents of the referenced list. Otherwise, replace the contents of the list with the arguments.

push_inst_var(@args)

Given a list of values, push them on to the end of the list. Return the new number of list elements.

push_inst_var_if_new(@args)

Given a list of values, push them on to the end of the list unless they already exist on he list. Returns the new number of list elements. Note that this method uses Perl's grep function and so is only suitable for short lists.

pop_inst_var

Pop a single value from the end of the list and return it.

unshift_inst_var(@args)

Given a list of values, unshift them on to the front of the list. Return the new number of list elements.

shift_inst_var()

Shift a single value from the front of the list and return it.

first_of_inst_var()

Return (but do not remove) the first element in the list. If the list is empty, return undef.

last_of_inst_var()

Return (but do not remove) the last element in the list. If the list is empty, return undef.

count_inst_var()

Return the number of elements currently on the list.

clear_inst_var()

Delete the contents of the list.

join_inst_var([$glue])

Return the join of the list. The list is not modified. If $glue is defined, join the list with the given glue. Otherwise, join the list with the empty string.

grep_inst_var($re)

Return the list generated by grepping the list against $re, which must be a compiled regular express (usually using qr//).

Object

Define methods in the destination class for an object-valued instance variable called inst_var.

For specifications of this form (scalar-valued):

   object => 'inst_var'

the scalar is used as the name of the instance variable.

For specifications of this form (hash-reference-valued), the instance variable is defined by attribute-value pairs in the referenced hash:

   object => { name => 'inst_var',
               class => 'Class::Name',
               delegate => [ 'method1', 'method2' ] }

The required name attribute gives the name of the instance variable.

The optional class attribute gives the name of the class (or one of its superclasses) whose objects can be assigned to this instance variable. Attempting to set the instance variable to instances of other classes throws an exception.

The optional delegate attribute takes a reference to a list of method names. These methods are defined in the destination class as methods that invoke the identically-named methods on the object referenced by the instance variable.

This specification defines the following methods in the destination class:

inst_var(...)

The method named the same as the instance variable is its getter and setter. When called with an argument, the instance variable is set to that value. If the specification includes a class attribute, the argument must be an object of that class or its subclasses (tested using Perl's isa built-in). Returns the value of the instance variable (which may have just been set).

clear_inst_var()

Undefine the object instance variable. This method is so named to make it consistent with other methods defined by this module.

Scalar

Define methods in the destination class for a scalar-valued instance variable called inst_var as follows:

   scalar => 'inst_var'

Alternatively, you may supply a hash reference as the argument to the scalar specification as follows:

  scalar => { name => 'inst_var', default => 42 }

In this case, the required name attribute gives the name of the scalar in the destination class. The optional default attribute supplies an initial value for the scalar in the destination class.

This specification defines the following methods in the destination class:

inst_var(...)

The method named the same as the instance variable is the setter and getter. If called with no arguments, returns the current value of the scalar. If called with an argument, the scalar is assigned that value.

clear_inst_var()

Undefine the instance variable. This method is so named to make it consistent with other methods defined by this module.

add_to_inst_var($val)

Add numeric $val to the current contents of the scalar.

inc_inst_var()

Increment the scalar by one and return its new value.

dec_inst_var()

Decrement the scalar by one and return its new value.

append_to_inst_var($val)

Append string $val to the current contents of the scalar.

Scalars

Define methods in the destination class for multiple scalar-valued instance variables as follows:

   scalars => [ 'alpha', 'beta', 'gamma' ]

This specification is a convenience for defining multiple scalar-valued instance variables. It takes a reference to a list of names and invokes the scalar specification for each. Hence, the above specification is entirely equivalent to this one:

   scalar => 'alpha',
   scalar => 'beta',
   scalar => 'gamma'

Note that there is no way to define a default value for each scalar in the scalars construct; use multiple scalar specifications instead.

Utility

Define various utility methods.

toString()

Define a method to convert an object to a string using Data::Dumper.

attributes_as_string(@attributes)

Return a string representation of the object, including attribute name-value pairs for attributes named in parameter list.

dump([$msge])

Define a method to dump an object using Data::Dumper. If $msge is defined, print it as a brief descriptive message before dumping the object. These methods are defined on all classes that use Methodist.

SEE ALSO

Top

Class::MakeMethods, Data::Dumper

BUGS

Top

Additional methods could probably be defined for several of the data types, but these are all the ones I've actually needed in practice.

AUTHOR

Top

Tom Nurkkala <tom@nerds4christ.com>

COPYRIGHT

Top

Copyright (c) 2006 by Tom Nurkkala. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Class-Methodist documentation Contained in the Class-Methodist distribution. 
package Class::Methodist;

use strict;
use warnings;
use Carp;


sub import {
  my ($my_class, @args) = @_;
  my $dest_class = caller;	# Caller's class for importing methods.

  while (my ($type, $spec) = splice(@args, 0, 2)) {
  SWITCH:
    for ($type) {
      /ctor/ and do {
	define_constructor($dest_class, $spec);
	last SWITCH;
      };

      /enum/ and do {
	define_enum_methods($dest_class, $spec);
	last SWITCH;
      };

      /hash$/ and do {
	define_hash_methods($dest_class, $spec);
	last SWITCH;
      };

      /hash_of_lists/ and do {
	define_hash_of_lists_methods($dest_class, $spec);
	last SWITCH;
      };

      /list/ and do {
	define_list_methods($dest_class, $spec);
	last SWITCH;
      };

      /object/ and do {
	define_object_methods($dest_class, $spec);
	last SWITCH;
      };

      /scalar$/ and do {
	define_scalar_methods($dest_class, $spec);
	last SWITCH;
      };

      /scalars/ and do {
	define_scalar_methods($dest_class, $_) foreach @$spec;
	last SWITCH;
      };

      confess "Invalid type '$type'";
    }
  }

  define_utility_methods($dest_class);
}

#----------------------------------------------------------------


sub verify_method_not_defined {
  my ($dest_class, $method) = @_;

  use Devel::Symdump;
  my @functions = Devel::Symdump->new($dest_class)->functions();

  if (grep { $_ eq $method } @functions) {
    confess "Method '$method' already exists in class '$dest_class'";
  }
}

#----------------------------------------------------------------


sub define_method {
  my ($dest_class, $method, $sub_ref) = @_;

  # Try turning this off for now.  Called a *lot*.  May not be of much
  # benefit.
  #
  # verify_method_not_defined($dest_class, $method);

  my $fq_name = sprintf('%s::%s', $dest_class, $method);
  {
    no strict 'refs';
    *{$fq_name} = $sub_ref;
  }
}

#----------------------------------------------------------------

{
  my %methodist_info;

  ## Return whether the named class has Methodist-internal data.  This
  ## subroutine was added to allow us to handle properly inheritance
  ## from classes that don't use Methodist (e.g., Class::Singleton).
  sub _has_methodist_info {
    my $dest_class = shift;
    exists $methodist_info{$dest_class};
  }

  ## Add @values to the list stored under $key in the Methodist-internal
  ## data for this class.
  sub _add_methodist_info {
    my ($dest_class, $key, @values) = @_;
    push @{$methodist_info{$dest_class}{$key}}, @values;
  }

  ## Return the list of values stored under $key in the
  ## Methodist-internal data for this class.  If no data are stored
  ## under that key, return an empty list.
  sub _get_methodist_info {
    my ($dest_class, $key) = @_;
    $methodist_info{$dest_class}{$key} ||= [ ];
    return @{$methodist_info{$dest_class}{$key}};
  }
}

#----------------------------------------------------------------


sub define_constructor {
  my ($dest_class, $name) = @_;

  ## Bless a hash reference into the destination class.
  define_method($dest_class, $name,
		sub {
		  $dest_class->beget();
		});
}

#----------------------------------------------------------------


sub define_enum_methods {
  my ($dest_class, $spec) = @_;

  my $name = $spec->{name};
  my @domain = @{$spec->{domain}};

  _add_methodist_info($dest_class, attributes => [ enum => $name ]);

  if (defined $spec->{default}) {
    croak sprintf("Default (%s) not among %s",
		  $spec->{default}, join(', ', @domain))
      unless (grep(/$spec->{default}/, @domain));
    _add_methodist_info($dest_class,
			default => [ $name => $spec->{default} ]);
  }


  define_method($dest_class, $name,
		sub {
		  my ($self, $arg) = @_;
		  if (defined($arg)) {
		    if (grep(/$arg/, @domain)) {
		      $self->{$name} = $arg;
		    } else {
		      croak sprintf("%s not among %s",
				    $arg, join(', ', @domain));
		    }
		  }
		  $self->{$name};
		});
}

#----------------------------------------------------------------


sub define_hash_methods {
  my ($dest_class, $name) = @_;

  _add_methodist_info($dest_class, attributes => [ hash => $name ]);


  define_method($dest_class, $name,
		sub {
		  my ($self, @args) = @_;
		  my $rtn = undef;

		  if (@args == 1) {
		    if (ref $args[0] eq 'HASH') {
		      $self->{$name} = $args[0];
		    } else {
		      $rtn = $self->{$name}{$args[0]};
		    }
		  } else {
		    while (my ($key, $val) = splice(@args, 0, 2)) {
		      $rtn = $self->{$name}{$key} = $val;
		    }
		  }
		  return $rtn;
		});


  define_method($dest_class, "${name}_exists",
		sub {
		  my ($self, $key) = @_;
		  confess "Must supply key" unless defined $key;
		  exists $self->{$name}{$key} ? 1 : undef;
		});


  define_method($dest_class, "${name}_keys",
		sub {
		  my $self = shift;
		  sort keys %{$self->{$name}};
		});


  define_method($dest_class, "${name}_values",
		sub {
		  my $self = shift;
		  sort values %{$self->{$name}}
		});


  define_method($dest_class, "${name}_clear",
		sub {
		  my $self = shift;
		  $self->{$name} = { };
		});


  define_method($dest_class, "${name}_delete",
		sub {
		  my ($self, $key) = @_;
		  delete $self->{$name}{$key};
		});


  define_method($dest_class, "${name}_size",
		sub {
		  my $self = shift;
		  scalar keys %{$self->{$name}};
		});


  define_method($dest_class, "${name}_inc",
		sub {
		  my ($self, $key, $n) = @_;
		  $n = 1 unless defined $n;
		  $self->{$name}{$key} += $n;
		});
}

#----------------------------------------------------------------


sub define_hash_of_lists_methods {
  my ($dest_class, $name) = @_;

  _add_methodist_info($dest_class, attributes => [ hash => $name ]);


  define_method($dest_class, $name,
		sub {
		  my ($self, @args) = @_;

		  my @rtn;
		  if (@args == 0) {
		    # Called with no arguments.  Return all the values
		    # stored in all the lists.
		    push @rtn, @$_ foreach values %{$self->{$name}};
		  } elsif (@args == 1) {
		    # Called with one argument.  Return all the values
		    # stored in the list having that value as a key
		    my $key = $args[0];
		    $self->{$name}{$key} = [ ]
		      unless defined $self->{$name}{$key};
		    @rtn = @{$self->{$name}{$key}};
		  } else {
		    confess "Must have zero or one arguments";
		  }

		  # Return values as a list in list context and as a
		  # list reference in scalar context.
		  if (wantarray) {
		    return @rtn;
		  } else {
		    return \@rtn;
		  }
		});


  define_method($dest_class, "${name}_push",
		sub {
		  my ($self, $key, @args) = @_;
		  push @{$self->{$name}{$key}}, @args;
		});


  define_method($dest_class, "${name}_keys",
		sub {
		  my $self = shift;
		  keys %{$self->{$name}};
		});
}

#----------------------------------------------------------------


sub define_list_methods {
  my ($dest_class, $name) = @_;

  _add_methodist_info($dest_class, attributes => [ list => $name ]);


  define_method($dest_class, $name,
		sub {
		  my ($self, @args) = @_;

		  if (@args == 0) {
		    # Called without arguments.  Return the contents
		    # of the list. as a list in list context and as a
		    # list reference in scalar context.
		    if (wantarray) {
		      return @{$self->{$name}};
		    } else {
		      return $self->{$name};
		    }
		  } elsif (@args == 1 and ref $args[0] eq 'ARRAY') {
		    # Called with reference to a list.  Replace the
		    # contents of the list with the elements
		    # referenced.
		    $self->{$name} = $args[0];
		  } else {
		    ## Called with multiple arguments. Replace the
		    ## contents of the list with those arguments
		    $self->{$name} = \@args;
		  }
		});


  define_method($dest_class, "push_$name",
		sub {
		  my ($self, @args) = @_;
		  push @{$self->{$name}}, @args;
		  scalar @{$self->{$name}};
		});


  define_method($dest_class, "push_${name}_if_new",
		sub {
		  my ($self, @args) = @_;
		  foreach my $arg (@args) {
		    push @{$self->{$name}}, $arg
		      unless grep($_ eq $arg, @{$self->{$name}});
		  }
		  scalar @{$self->{$name}};
		});


  define_method($dest_class, "pop_$name",
		sub {
		  my $self = shift;
		  pop @{$self->{$name}};
		});


  define_method($dest_class, "unshift_$name",
		sub {
		  my ($self, @args) = @_;
		  unshift @{$self->{$name}}, @args;
		  scalar @{$self->{$name}};
		});


  define_method($dest_class, "shift_$name",
		sub {
		  my $self = shift;
		  shift @{$self->{$name}};
		});


  define_method($dest_class, "first_of_$name",
		sub {
		  my $self = shift;
		  @{$self->{$name}} ? $self->{$name}[0] : undef;
		});


  define_method($dest_class, "last_of_$name",
		sub {
		  my $self = shift;
		  @{$self->{$name}} ? $self->{$name}[-1] : undef;
		});


  define_method($dest_class, "count_$name",
		sub {
		  my $self = shift;
		  scalar @{$self->{$name}};
		});


  define_method($dest_class, "clear_$name",
		sub {
		  my $self = shift;
		  $self->{$name} = [ ];
		});


  define_method($dest_class, "join_$name",
		sub {
		  my ($self, $glue) = @_;
		  $glue = '' unless defined $glue;
		  join($glue, @{$self->{$name}});
		});


  define_method($dest_class, "grep_$name",
		sub {
		  my ($self, $re) = @_;
		  grep(/$re/, @{$self->{$name}});
		});
}

#----------------------------------------------------------------


sub define_object_methods {
  my ($dest_class, $spec) = @_;

  my $name = undef;
  my $required_class = undef;
  my @delegate;

  if (ref($spec) eq 'HASH') {
    $name = $spec->{name};
    $required_class = $spec->{class};
    @delegate = @{$spec->{delegate}} if exists $spec->{delegate};
  } else {
    $name = $spec;
  }

  confess "No name specified" unless defined $name;


  define_method($dest_class, $name,
		sub {
		  my ($self, $arg) = @_;

		  if (defined $arg) {
		    # Called with an argument.
		    confess "Must pass an object as value" unless ref $arg;
		    if ($required_class) {
		      # The 'class' attribute was supplied; the
		      # argument must be of the specified class.
		      my $arg_class = ref $arg;
		      confess "Requires '$required_class', not '$arg_class'"
			unless $arg->isa($required_class);
		    }
		    # Assign the value to the argument.
		    $self->{$name} = $arg;
		  }

		  # Return the current object (whether arguments or not).
		  $self->{$name};
		});

  # Created delegates, if any.
  foreach my $delegate (@delegate) {
    define_method($dest_class, $delegate,
		  sub {
		    my ($self, @args) = @_;
		    $self->{$name}->$delegate(@args);
		  });
  }


  define_method($dest_class, "clear_$name",
		sub {
		  my $self = shift;
		  $self->{$name} = undef;
		});
}

#----------------------------------------------------------------


sub define_scalar_methods {
  my ($dest_class, $spec) = @_;

  my $name = undef;

  if (ref($spec) eq 'HASH') {
    $name = $spec->{name};

    if (defined $spec->{default}) {
      _add_methodist_info($dest_class,
			  default => [ $name => $spec->{default} ]);
    }
  } else {
    $name = $spec;
  }

  _add_methodist_info($dest_class, attributes => [ scalar => $name ]);


  define_method($dest_class, $name,
		sub {
		  my ($self, $arg) = @_;
		  if (defined $arg) {
		    return $self->{$name} = $arg;
		  }
		  $self->{$name};
		});


  define_method($dest_class, "clear_$name",
		sub {
		  my $self = shift;
		  $self->{$name} = undef;
		});


  define_method($dest_class, "add_to_$name",
		sub {
		  my ($self, $val) = @_;
		  $self->{$name} += $val;
		});


  define_method($dest_class, "inc_$name",
		sub {
		  my $self = shift;
		  $self->{$name}++;
		});


  define_method($dest_class, "dec_$name",
		sub {
		  my $self = shift;
		  $self->{$name}--;
		});


  define_method($dest_class, "append_to_$name",
		sub {
		  my ($self, $val) = @_;
		  $self->{$name} .= $val;
		});
}

#----------------------------------------------------------------


#----------------------------------------------------------------


{
  use Class::ISA;

  # Cache previous results from self_and_super_path, which takes a
  # fair amount of time and is called a *lot* because it's in beget().
  my %self_and_super;

  # Invoke self_and_super_path (which returns the ordered list of
  # names of classes that Perl would search in order to find a
  # method).  Cache and return results.
  sub _self_and_super {
    my $class = shift;

    my $rtn = undef;
    if (exists $self_and_super{$class}) {
      $rtn = $self_and_super{$class};
    } else {
      my @self_and_super = Class::ISA::self_and_super_path($class);
      $rtn = $self_and_super{$class} = \@self_and_super;
    }

    return $rtn;
  }
}

sub define_utility_methods {
  my $dest_class = shift;

  define_method($dest_class, 'beget',
		sub {
		  my ($dest_class, %initializers) = @_;

		  my $self = bless { }, $dest_class;
		  $self->equip(%initializers);
		});

  define_method($dest_class, 'equip',
		sub {
		  my ($self, %initializers) = @_;

		  foreach my $class (@{_self_and_super(ref $self)}) {
		    next unless _has_methodist_info($class);

		    foreach my $pair (_get_methodist_info($class,
							  'attributes')) {
		      my ($type, $name) = @$pair;
		    SWITCH:
		      for ($type) {
			/scalar|enum/ and do {
			  $self->{$name} = undef;
			  last SWITCH;
			};
			/list/ and do {
			  $self->{$name} = [ ];
			  last SWITCH;
			};
			/hash/ and do {
			  $self->{$name} = { };
			  last SWITCH;
			};
			confess "Invalid type '$type'";
		      }
		    }

		    foreach my $pair (_get_methodist_info($class,
							  'default')) {
		      my ($name, $default) = @$pair;
		      $self->{$name} = $default;
		    }
		  }

		  while (my ($key, $value) = each %initializers) {
		    $self->$key($value);
		  }

		  return $self;
		});

  use Data::Dumper;
  $Data::Dumper::Indent = 1;


  define_method($dest_class, 'toString',
		sub {
		  my $self = shift;
		  Data::Dumper->Dump([ $self ], [ ref $self ]);
		});


  sub ansi_magenta { "\e[35m" }
  sub ansi_underline { "\e[4m" }
  sub ansi_reset { "\e[0m" }

  define_method($dest_class, 'attributes_as_string',
		sub {
		  my ($self, @attributes) = @_;
		  my @pairs;
		  foreach my $attribute (@attributes) {
		    my $value = $self->{$attribute} || 'UNDEF';

		    if (ref($value) eq 'ARRAY') {
		      $value = sprintf('[%s]', join(',', @$value));

		    } elsif (ref($value) eq 'HASH') {
		      my @contents =
			map { sprintf("%s=%s", $_, $value->{$_} || 'UNDEF') }
			  sort keys %$value;
		      $value = sprintf('{%s}', join(',', @contents));
		    }

		    # Use ANSI colorization for attribute name.
		    push @pairs,
		      sprintf('%s%s%s=%s',
			      ansi_magenta, $attribute, ansi_reset, $value)
		  }
		  sprintf('(%s %s)', ref($self), join(',', @pairs));
		});


  define_method($dest_class, 'dump',
		sub {
		  my ($self, $msge) = @_;

		  print "==== $msge ====\n" if $msge;
		  print $self->toString();
		});
}

'SDG';				# Return true

__END__