use 5.008008;
use strict;
use warnings;

package Marlin::X::Clone;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.014000';

use Carp 'croak';
use Clone;
use Eval::TypeTiny::CodeAccumulator;
use Types::Common -types;

use Marlin
	# All Marlin::X::* plugins need to accept these attributes
	marlin      => { isa => Object,  required => !!1, },
	try         => { isa => Bool,    default => !!0, },
	# These are specific to Marlin::X::Clone
	method_name => { isa => Str,     default => 'clone' },
	call_build  => { isa => Bool,    default => !!1 },
	strict_args => { isa => Bool,    default => !!1 },
	;

# Is possible to do some sanity checking here.
sub BUILD {
	my $plugin = shift;
	if ( $plugin->marlin->isa('Marlin::Role') ) {
		croak "Marlin::X::Clone cannot be applied to roles";
	}
}

# This is the main hook Marlin uses to give plugins a chance to do something.
# $steps is a list of subs which will be called by Marlin when setting up the
# class or role. Plugins can add or remove steps.
sub adjust_setup_steps {
	my $plugin = shift;
	my $steps  = shift;

	# Add an extra step called "Marlin::X::Clone::setup_clone_method".
	# In our case, it doesn't really matter where we add the step, so
	# we'll just add it at the end.
	push @$steps, sprintf '%s::%s', __PACKAGE__, 'setup_clone_method';
}

# When our step is called, it is passed the Marlin object and the plugin
# object. Note the Marlin object is the FIRST parameter!
sub setup_clone_method {
	my $marlin = shift;
	my $plugin = shift;
	
	# All we're doing here is creating a method called "clone" and
	# then telling Marlin to export it.
	my $code = $plugin->_make_clone_method( $marlin );
	$marlin->export( $plugin->method_name, $code->compile );
	
	# Marlin offers "export" and "lexport". The former will export methods
	# into the class/role currently being built. The latter will export a
	# function lexically into the compiling package (or the caller if lexical
	# exports are unavailable).
	#
	# Use "export" to install methods into the class being built. Use
	# "lexport" for utility functions, keywords, etc.
	
	return $marlin;
}

# This is the guts to the Marlin::X::Clone plugin. It is building up
# a coderef as a string using Eval::TypeTiny::CodeAccumulator. Using
# CodeAccumulator is just a little prettier than concatenating strings
# and doing an `eval` at the end.
sub _make_clone_method {
	my $plugin = shift;
	my $marlin = shift;
	
	my $code = Eval::TypeTiny::CodeAccumulator->new( description => 'clone' );
	$code->addf( 'sub {' );
	$code->increase_indent;
	$code->addf( 'my $self  = shift;' );
	$code->addf( InstanceOf->of( $marlin->this )->inline_assert('$self') );
	$code->addf( 'my $class = ref $self;' );

	# ->clone() has been called on a child class which doesn't override clone.
	# This means it may need to handle additional attributes. So attempt to
	# create a clone method for the child class!
	{
		my $var = $code->add_variable( '$clone_plugin', \$plugin );
		$code->addf( 'if ( $class ne %s ) {', B::perlstring($marlin->this) );
		$code->increase_indent;
		$code->addf( 'my $child_marlin = %s->find_meta( $class ) or %s("$class is not a Marlin class");', ref($marlin), $marlin->_croaker );
		$code->addf( 'my $child_cloner = %s->_make_clone_method_for_child( $child_marlin );', $var );
		$code->addf( 'return $self->$child_cloner( @_ );' );
		$code->decrease_indent;
		$code->addf( '}' );
	}

	$code->addf( 'my %%args  = ( @_ == 1 and %s ) ? %%{+shift} : @_;', HashRef->inline_check('$_[0]') );
	$code->addf( 'my $clone = bless( {}, $class );' );
	$code->addf( 'my $used = 0;' ) if $plugin->strict_args;
	$code->add_gap;
	
	$marlin->canonicalize_attributes;
	my @allowed;
	
	for my $attr ( @{ $marlin->attributes_with_inheritance } ) {
		
		if ( not exists $attr->{on_clone} ) {
			$attr->{on_clone} = ( $attr->{storage} ne 'PRIVATE' );
		}
		
		$code->addf( '{' );
		$code->increase_indent;
		$code->addf( 'my ( $value, $has_value );' );
		
		my @aliases;
		@aliases = @{ $attr->{':Alias'}{alias} or [] } if $attr->{':Alias'};
		
		my $if = 'if';
		my $init_arg = exists( $attr->{init_arg} ) ? $attr->{init_arg} : $attr->{slot};
		push @allowed, $init_arg if defined $init_arg;
		
		if ( @aliases ) {
			$code->addf( 'if ( my @found = grep { exists $args{$_} } %s ) {',
				join( q[, ] => map { B::perlstring($_) } $init_arg, @aliases ) );
			$code->increase_indent;
			$code->addf( 'if ( @found > 1 ) {' );
			$code->increase_indent;
			$code->addf( 'shift @found;' );
			$code->addf( '%s("Superfluous %%s used for attribute \'%%s\': %%s" , @found==1 ? "alias" : "aliases", %s, join( q[, ], sort @found ) );', $attr->_croaker, B::perlstring($attr->{slot}) );
			$code->decrease_indent;
			$code->addf( '}' );
			$code->addf( '( $value, $has_value ) = ( $args{$found[0]}, !!1 );' );
			$code->addf( '$used++;' ) if $plugin->strict_args;
			$code->addf( 'undef $has_value unless defined $value;' ) if $attr->{undef_tolerant};
			$code->decrease_indent;
			$code->addf( '}' );
			$if = 'elsif';
			push @allowed, @aliases;
		}
		elsif ( defined $init_arg ) {
			$code->addf( 'if ( exists $args{%s} ) {', B::perlstring($init_arg) );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( $args{%s}, !!1 );', B::perlstring($init_arg) );
			$code->addf( '$used++;' ) if $plugin->strict_args;
			$code->addf( 'undef $has_value unless defined $value;' ) if $attr->{undef_tolerant};
			$code->decrease_indent;
			$code->addf( '}' );
			$if = 'elsif';
		}
		
		if ( $attr->{on_clone} eq 1 or not exists $attr->{on_clone} ) {
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( %s, !!1 );', $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( 'CODE' eq ref $attr->{on_clone} ) {
			my $var = $code->add_variable( $attr->make_var_name('cloner'), \$attr->{on_clone} );
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( scalar $self->%s( %s, %s ), !!1 );', $var, B::perlstring($attr->{slot}), $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( $attr->{on_clone} eq 0 or $attr->{on_clone} eq ':none' ) {
			# no clone
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /:method\((.+?)\)/ ) {
			my $clone_method = $1;
			$code->addf( '%s ( %s and Scalar::Util::blessed( %s ) ) {', $if, $attr->inline_predicate('$self'), $attr->inline_access('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( ( %s )->%s, !!1 );', $attr->inline_access('$self'), $clone_method );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /:method/ ) {
			$code->addf( '%s ( %s and Scalar::Util::blessed( %s ) ) {', $if, $attr->inline_predicate('$self'), $attr->inline_access('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( ( %s )->clone, !!1 );', $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /:selfmethod\((.+?)\)/ ) {
			my $clone_method = $1;
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( scalar $self->%s( %s, %s ), !!1 );', $clone_method, B::perlstring($attr->{slot}), $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /^[\W0-9]\w+$/ ) {
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( scalar $self->%s( %s, %s ), !!1 );', $attr->{on_clone}, B::perlstring($attr->{slot}), $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /:deep/ ) {
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( scalar Clone::clone( %s ), !!1 );', $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( !ref $attr->{on_clone} and $attr->{on_clone} =~ /:simple/ ) {
			$code->addf( '%s ( %s ) {', $if, $attr->inline_predicate('$self') );
			$code->increase_indent;
			$code->addf( '( $value, $has_value ) = ( %s, !!1 );', $attr->inline_access('$self') );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		
		$code->addf( 'if ( $has_value ) {' );
		$code->increase_indent;
		$code->add_line( $attr->inline_writer( '$clone', '$value' ) );
		$code->decrease_indent;
		$code->addf( '}' );
		
		if ( ( exists $attr->{default} or defined $attr->{builder} ) and not $attr->{lazy} ) {
			my $var = $code->add_variable( $attr->make_var_name('default'), \$attr->{default} );
			$code->addf( 'else {' );
			$code->increase_indent;
			$code->addf( '$value = %s;', $attr->inline_default('$clone', $var) );
			delete local $attr->{trigger};
			$code->add_line( $attr->inline_writer( '$clone', '$value' ) );
			$code->decrease_indent;
			$code->addf( '}' );
		}
		elsif ( $attr->{required} ) {
			$code->addf( 'else {' );
			$code->increase_indent;
			$code->addf( '%s("Missing required attribute \'%%s\'" , %s );', $attr->_croaker, B::perlstring($attr->{slot}) );
			$code->decrease_indent;
			$code->addf( '}' );
		}

		$code->decrease_indent;
		$code->addf( '}' );
		$code->add_gap;
	}
	
	if ( $plugin->call_build ) {
		$code->addf( 'if ( not delete $args{__no_BUILD__} ) {' );
		$code->increase_indent;
		$code->addf( '$%s::BUILD_CACHE{$class} ||= do {', ref($marlin) );
		$code->increase_indent;
		$code->add_line( 'no strict "refs";' );
		$code->add_line( 'my $linear_isa = mro::get_linear_isa($class);' );
		$code->add_line( '[ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ];' );
		$code->decrease_indent;
		$code->add_line( '};' );
		$code->addf( '$_->( $clone, \%%args ) for @{ $%s::BUILD_CACHE{$class} };', ref($marlin) );
		$code->add_gap;
		$code->decrease_indent;
		$code->add_line( '}' );
	}
	
	if ( $plugin->strict_args ) {
		my $check = do {
			my $enum = Enum->of( @allowed );
			$enum->can( '_regexp' )
				? sprintf( '/\\A%s\\z/', $enum->_regexp )
				: $enum->inline_check( '$_' );
		};
		$code->addf( 'if ( keys( %%args ) > $used ) {' );
		$code->increase_indent;
		$code->addf( 'my @unknown = grep not( %s ), keys %%args;', $check );
		$code->addf( '%s("Unexpected keys in clone arguments: " . join( q[, ], sort @unknown ) ) if @unknown;', $marlin->_croaker );
		$code->decrease_indent;
		$code->add_line( '}' );
		$code->add_gap;
	}
	
	$code->addf('return $clone;');
	$code->decrease_indent;
	$code->addf( '}' );
	
	# warn $code->code;
	
	return $code;
}

# Utility method used by ->clone() to prepare a separate ->clone() method
# for any child classes.
sub _make_clone_method_for_child {
	my $plugin = shift;
	my $marlin = shift;
	my $code = $plugin->_make_clone_method( $marlin );
	my $coderef = $code->compile;
	
	$marlin->export( $plugin->method_name, $coderef );
	return $coderef;
}

1;

__END__

=pod

=encoding utf-8

=head1 NAME

Marlin::X::Clone - Marlin extension to add a C<clone> method to your class.

=head1 SYNOPSIS

  package Local::Date {
    use Marlin qw( year month day :Clone );
  }
  
  my $xmas     = Local::Date->new( day => 25, month => 12, year => 2025 );
  my $xmas_eve = $xmas->clone( day => 24 );

=head1 DESCRIPTION

This package creates a method in your class that does roughly:

  sub clone {
    my ( $self, %args ) = @_;
    my %clone = ( %$self, %args );
    return bless \%clone, ref($self);
  }

Except it also:

=over

=item *

Skips over "PRIVATE" storage attributes by default.

=item *

Respects the C<init_arg> for each attribute.

=item *

Calls trigger methods, uses defaults, checks type constraints, and does type coercions.

=item *

Allows per-attribute tweaks to its behaviour.

=item *

Calls C<BUILD> methods.

=item *

Complains if you give it arguments which it doesn't recognize.

=back

You can tweak an attribute's behaviour using:

  use Marlin foo => { on_clone => ... };

Valid values for C<on_clone>:

=over

=item C<< :simple >>

A simple shallow copy. If the value is a reference, the cloned value will
refer to the same data.

  ## on_clone => ':simple'
  $clone->{foo} = $self->{foo};

This is the default and will be used if C<on_clone> is omitted, or
for C<< on_clone => true >>.

=item C<< :deep >>

Uses the L<Clone> module to make a deep clone of the original value.

  ## on_clone => ':deep'
  $clone->{foo} = Clone::clone( $self->{foo} );

=item C<< :none >>

Does not clone the attribute value.

You can also specify this as C<< on_clone => false >>.

=item C<< :method >> or C<< :method(NAME) >>

Calls a method on the original value, assuming it's a blessed object. If the
original value is not a blessed object, it will silently be skipped. If no
C<NAME> is provided, the name is assumed to be "clone".

  ## on_clone => ':method'
  if ( blessed $self->{foo} ) {
    $clone->{foo} = $self->{foo}->clone;
  }
  
  ## on_clone => ':method(make_copy)'
  if ( blessed $self->{foo} ) {
    $clone->{foo} = $self->{foo}->make_copy;
  }

=item C<< :selfmethod(NAME) >>

Calls a method on the original object.

  ## on_clone => ':selfmethod(make_copy)'
  $clone->{foo} = $self->make_copy( foo => $self->{foo} );

You can also specify this as C<< on_clone => "NAME" >> as a shortcut.

=item CODE

Setting C<< on_clone => sub {...} >> will call the coderef in a similar
style to C<< :selfmethod >>.

  ## on_clone => $coderef
  $clone->{foo} = $self->$coderef( foo => $self->{foo} );

=back

Because C<< :method >> only works when the value is a blessed object,
you can indicate a fallback that will be used in other cases.

  ## on_clone => ':method(make_copy) :deep'
  if ( blessed $self->{foo} ) {
    $clone->{foo} = $self->{foo}->make_copy;
  }
  else {
    $clone->{foo} = Clone::clone( $self->{foo} );
  }
  
  ## on_clone => ':method(make_copy) :copy'
  if ( blessed $self->{foo} ) {
    $clone->{foo} = $self->{foo}->make_copy;
  }
  else {
    $clone->{foo} = $self->{foo};
  }
  
  ## on_clone => ':method(make_copy) :none'
  if ( blessed $self->{foo} ) {
    $clone->{foo} = $self->{foo}->make_copy;
  }

You can also set a few options for how the plugin behaves:

  use Marlin qw( foo bar ),
    ':Clone' => {
      method_name     => 'clone', # Name for the clone method
      call_build      => true,    # Call BUILD after cloning?
      strict_args     => true,    # Complain about unrecognized params?
    };

This module also acts as a demonstration of Marlin's extension API.
See comments in the source code for more details.

=head1 BUGS

Please report any bugs to
L<https://github.com/tobyink/p5-marlin/issues>.

=head1 SEE ALSO

L<Marlin>.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2025-2026 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

🐟🐟
