* Move files to trunk

1 files changed, 207 insertions, 0 deletions

diff --git a/lib/Class/MakeMethods/Template/Ref.pm b/lib/Class/MakeMethods/Template/Ref.pm
new file mode 100644
index 0000000..d97bafa
--- /dev/null
+++ b/lib/Class/MakeMethods/Template/Ref.pm
@@ -0,0 +1,207 @@
+=head1 NAME
+
+Class::MakeMethods::Template::Ref - Universal copy and compare methods
+
+=head1 SYNOPSIS
+
+  package MyObject;
+  use Class::MakeMethods::Template::Ref (
+    'Hash:new'      => [ 'new' ],
+    clone           => [ 'clone' ]
+  );
+  
+  package main;
+
+  my $obj = MyObject->new( foo => ["Foozle", "Bozzle"] );
+  my $clone = $obj->clone();
+  print $obj->{'foo'}[1];
+
+=cut
+
+package Class::MakeMethods::Template::Ref;
+
+$VERSION = 1.008;
+use strict;
+require 5.00;
+use Carp;
+
+use Class::MakeMethods::Template '-isasubclass';
+use Class::MakeMethods::Utility::Ref qw( ref_clone ref_compare );
+
+######################################################################
+
+=head1 DESCRIPTION
+
+The following types of methods are provided via the Class::MakeMethods interface:
+
+=head2 clone
+
+Produce a deep copy of an instance of almost any underlying datatype. 
+
+Parameters:
+
+init_method 
+  
+If defined, this method is called on the new object with any arguments passed in.
+
+=cut
+
+sub clone {
+  {
+    'params' => { 'init_method' => '' },
+    'interface' => {
+      default => 'clone',
+      clone => { '*'=>'clone',  },
+    },
+    'behavior' => {
+      'clone' => sub { my $m_info = $_[0]; sub {
+	  my $callee = shift; 
+	  ref $callee or croak "Can only copy instances, not a class.\n";
+	  
+	  my $self = ref_clone( $callee );
+	  
+	  my $init_method = $m_info->{'init_method'};
+	  if ( $init_method ) {
+	    $self->$init_method( @_ );
+	  } elsif ( scalar @_ ) {
+	    croak "No init_method";
+	  }
+	  return $self;
+	}},
+    },
+  } 
+}
+
+######################################################################
+
+=head2 prototype
+
+Create new instances by making a deep copy of a static prototypical instance. 
+
+Parameters:
+
+init_method 
+  
+If defined, this method is called on the new object with any arguments passed in.
+=cut
+
+sub prototype {
+  ( {
+    'interface' => {
+      default => { '*'=>'set_or_new',  },
+    },
+    'behavior' => {
+      'set_or_new' => sub { my $m_info = $_[0]; sub {
+	my $class = shift;
+	
+	if ( scalar @_ == 1 and UNIVERSAL::isa( $_[0], $class ) ) {
+	  # set
+	  $m_info->{'instance'} = shift 
+	
+	} else {
+	  # get
+	  croak "Prototype is not defined" unless $m_info->{'instance'};
+	  my $self = ref_clone($m_info->{'instance'});
+	  
+	  my $init_method = $m_info->{'init_method'};
+	  if ( $init_method ) {
+	    $self->$init_method( @_ );
+	  } elsif ( scalar @_ ) {
+	    croak "No init_method";
+	  }
+	  return $self;
+	}
+      }},
+      'set' => sub { my $m_info = $_[0]; sub {
+	my $class = shift;
+	$m_info->{'instance'} = shift 
+      }},
+      'new' => sub { my $m_info = $_[0]; sub {
+	my $class = shift;
+	
+	croak "Prototype is not defined" unless $m_info->{'instance'};
+	my $self = ref_clone($m_info->{'instance'});
+	
+	my $init_method = $m_info->{'init_method'};
+	if ( $init_method ) {
+	  $self->$init_method( @_ );
+	} elsif ( scalar @_ ) {
+	  croak "No init_method";
+	}
+	return $self;
+      }},
+    },
+  } )
+}
+
+######################################################################
+
+=head2 compare
+
+Compare one object to another. 
+
+B<Templates>
+
+=over 4
+
+=item *
+
+default
+
+Three-way (sorting-style) comparison.
+
+=item *
+
+equals
+
+Are these two objects equivalent?
+
+=item *
+
+identity
+
+Are these two references to the exact same object?
+
+=back
+
+=cut
+
+sub compare {
+  {
+    'params' => { 'init_method' => '' },
+    'interface' => {
+      default => { '*'=>'compare',  },
+      equals => { '*'=>'equals',  },
+      identity => { '*'=>'identity',  },
+    },
+    'behavior' => {
+      'compare' => sub { my $m_info = $_[0]; sub {
+	  my $callee = shift; 
+	  ref_compare( $callee, shift );
+	}},
+      'equals' => sub { my $m_info = $_[0]; sub {
+	  my $callee = shift; 
+	  ref_compare( $callee, shift ) == 0;
+	}},
+      'identity' => sub { my $m_info = $_[0]; sub {
+	  $_[0] eq $_[1]
+	}},
+    },
+  } 
+}
+
+######################################################################
+
+=head1 SEE ALSO
+
+See L<Class::MakeMethods> for general information about this distribution. 
+
+See L<Class::MakeMethods::Template> for more about this family of subclasses.
+
+See L<Class::MakeMethods::Utility::Ref> for the clone and compare functions used above.
+
+=cut
+
+######################################################################
+
+1;