#!perl
use strict;
use warnings 'all' => 'FATAL';
use Getopt::Long ();
use Pod::Usage ();

Getopt::Long::GetOptions(
    help => \ &Pod::Usage::pod2usage,
)
    or Pod::Usage::pod2usage();
if ( @ARGV ) {
    open OUT, '>', $ARGV[0]
	or die "Can't open $ARGV[0] for writing: $!";
    select OUT;
}

{
    local @INC = ( @INC, 'lib' );
    require Devel::Spy::_constants;
}

my $SELF           = Devel::Spy::SELF();
my $OTHER          = Devel::Spy::OTHER();
my $INVERTED       = Devel::Spy::INVERTED();

my $TIED_PAYLOAD   = Devel::Spy::TIED_PAYLOAD();
my $UNTIED_PAYLOAD = Devel::Spy::UNTIED_PAYLOAD();
my $CODE           = Devel::Spy::CODE();

require overload;

print <<"HEADER";
#
# Devel/Spy/_overload.pm
#
# Copyright (C) ... by Joshua ben Jore
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
#  This file is built by @{[__FILE__]} from its data.  Any changes made here
#  will be lost!
#

package Devel::Spy::_obj;
use strict;
use warnings;

require Sub::Name;
require overload;

HEADER

# Shadow both isa and can methods. I want to make sure other things
# like overload.pm can still make requests about the Devel::Spy::_obj
# class with ->isa and ->can but any request about an object get
# forwarded to the inner, wrapped object.
#
# TODO: should other wrapped methods like DESTROY, ref, import, AUTOLOAD also go here?
print
    map {
        my $method = $_;
        <<"ISA";
sub $method {
    my \$self = shift \@_;

    if ( defined Scalar::Util::blessed( \$self ) ) {
        my \$followup = \$self->[$CODE]->( '->$method' );
        # Object method call passed onto our stored thing.
        return Devel::Spy->new( \$self->[$UNTIED_PAYLOAD]->$method( \@_ ),
        \$followup );
    }
    else {
        # Class method call on Devel::Spy::_obj. Just forward
        # to UNIVERSAL or whatever else is there.
        return \$self->SUPER::$method( \@_ );
    }
}
ISA
    }
    qw(
        isa
        DOES
        can
    );

print <<"OVERLOADS";
my \@overloading = (
    'fallback' => 0,
    '=' => Sub::Name::subname(
        '=',
        sub {
            my \$class = CORE::ref \$_[$SELF];
            my \$followup = \$_[$SELF][$CODE]->(
                '->(= '
                . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                    ? \$_[$SELF][$UNTIED_PAYLOAD]
                    : 'undef' )
                . ') -> ');
            return Devel::Spy->new( \$_[$SELF][$UNTIED_PAYLOAD], \$followup );
        }
    ),
    'atan2' => Sub::Name::subname(
        'atan2',
        sub {
            my ( \$result, \$followup );
            if ( \$_[$INVERTED] ) {
                \$result = atan2 \$_[$OTHER], \$_[$SELF][$TIED_PAYLOAD];
                \$followup = \$_[$SELF][$CODE]->(
                    ' ->(atan2 '
                    . ( defined \$_[$OTHER]
                        ? \$_[$OTHER]
                        : 'undef')
                    . ', '
                    . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                        ? \$_[$SELF][$UNTIED_PAYLOAD]
                        : 'undef')
                    . ') ->'
                    . overload::StrVal(\$result) );
            }
            else {
                \$result = atan2 \$_[$SELF][$TIED_PAYLOAD], \$_[$OTHER];
                \$followup = \$_[$SELF][$CODE]->(
                    ' ->(atan2 '
                    . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                        ? \$_[$SELF][$UNTIED_PAYLOAD]
                        : 'undef')
                    . ', '
                    . ( defined \$_[$OTHER]
                        ? \$_[$OTHER]
                        : 'undef')
                    . ') ->'
                    . overload::StrVal(\$result) );
            }
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
    '-X' => Sub::Name::subname(
        '-X',
        sub {
            my \$result =
                \$_[2] eq 'r' ? ( -r \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'w' ? ( -w \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'x' ? ( -x \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'o' ? ( -o \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'R' ? ( -R \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'W' ? ( -W \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'X' ? ( -X \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'O' ? ( -O \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'e' ? ( -e \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'z' ? ( -z \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 's' ? ( -s \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'f' ? ( -f \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'd' ? ( -d \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'l' ? ( -l \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'p' ? ( -p \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'S' ? ( -S \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'b' ? ( -b \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'c' ? ( -c \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 't' ? ( -t \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'u' ? ( -u \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'g' ? ( -g \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'k' ? ( -k \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'T' ? ( -T \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'B' ? ( -B \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'M' ? ( -M \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'A' ? ( -A \$_[$SELF][$TIED_PAYLOAD] ) :
                \$_[2] eq 'C' ? ( -C \$_[$SELF][$TIED_PAYLOAD] ) :
                eval( "-\$_[2] \$_[$SELF][$TIED_PAYLOAD]" );
            my \$followup = \$_[$SELF][$CODE]->(
                " ->(-\$_[2] "
                . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                    ? \$_[$SELF][$UNTIED_PAYLOAD]
                    : 'undef' )
                . ') ->'
                . overload::StrVal(\$result) );
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
    '<>' => Sub::Name::subname(
        '<>',
        sub {
            my \$result = readline \$_[$SELF][$TIED_PAYLOAD];
            my \$followup = \$_[$SELF][$CODE]->(
                ' ->(readline '
                . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                    ? \$_[$SELF][$UNTIED_PAYLOAD]
                    : 'undef' )
                . ') ->'
                . overload::StrVal(\$result) );
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
OVERLOADS

print
    map {
        my $deref = $_;
        <<"DEREFERENCING";
    '${deref}' => Sub::Name::subname(
        '${deref}',
        sub {

            # Allow ourselves to access our own guts and let
            # everyone else have the payload.
            if ( caller() eq 'Devel::Spy::_obj' ) {
                return \$_[$SELF];
            }
            else {
                # This idea is really dodgy but I found myself in
                # an infinite loop of some kind when I returned a
                # plain Devel::Spy object wrapping the
                # result. Bummer.
                my \$followup = \$_[$SELF][$CODE]->( ' ->$deref' );
                my \$tied = \$_[$SELF][$TIED_PAYLOAD];
                my \$reftype = CORE::ref( \$tied );
                my \$obj =
                    'HASH'   eq \$reftype ? ( tied %\$tied  ) :
                    'ARRAY'  eq \$reftype ? ( tied \@\$tied ) :
                    \$reftype =~ /
                        ^
                        (?:
                            SCALAR
                          | REF
                          | LVALUE
                          | REGEXP
                          | VSTRING
                          | BIND
                        )
                        \\z
                    /x
                        ? ( tied \$\$tied ) :
                    'CODE'   eq \$reftype ? ( tied &\$tied  ) :
                    \$reftype =~ /
                        ^
                        (?:
                            GLOB
                          | FORMAT
                          | IO
                        )
                        \\z
                    /x
                        ? ( tied *\$tied ) :
                    die "Unknown reftype \$reftype for object \$tied";
                \$obj->[1] = \$followup;
                return \$tied;
            }
        }
    ),
DEREFERENCING
    }
    split ' ',
    $overload::ops{dereferencing};

print
    map {
        my $converter = $_;
        <<"CONVERSION";
    '${converter}' => Sub::Name::subname(
        '${converter}',
        sub {
            \$_[$SELF][$CODE]->(' ->$converter');
            return \$_[$SELF][$TIED_PAYLOAD];
        }
    ),
CONVERSION
    }
    split ' ',
    $overload::ops{conversion};

# Do a common things for all these common binary operators except |=,
# &=, and ^= which are assignment operators and will handled
# elsewhere.
print
    map {
        my $op = $_;
        <<"BINARY";
    '${op}' => Sub::Name::subname(
        '${op}',
        sub {
            my ( \$result, \$followup );
            if ( \$_[$INVERTED] ) {
                \$result = \$_[$OTHER] $op \$_[$SELF][$TIED_PAYLOAD];
                \$followup = \$_[$SELF][$CODE]->(
                    ' ->('
                    . ( defined \$_[$OTHER]
                        ? \$_[$OTHER]
                        : 'undef')
                    . ' $op '
                    . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                        ? \$_[$SELF][$UNTIED_PAYLOAD]
                        : 'undef')
                    . ') ->'
                    . overload::StrVal(\$result) );
            }
            else {
                \$result = \$_[$SELF][$TIED_PAYLOAD] $op \$_[$OTHER];
                \$followup = \$_[$SELF][$CODE]->(
                    ' ->('
                    . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                        ? \$_[$SELF][$UNTIED_PAYLOAD]
                        : 'undef')
                    . ' $op '
                    . ( defined \$_[$OTHER]
                        ? \$_[$OTHER]
                        : 'undef')
                    . ') ->'
                    . overload::StrVal(\$result) );
            }
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
BINARY
    }
    grep { ! /^[|&^]=\z/ }
    map split(' '),
    @overload::ops{qw(
        with_assign
        num_comparison
        3way_comparison
        str_comparison
        binary
        matching
    )};

# Handle ++ and --. Overload's copy constructor will take care of
# post-inc/decrement by first making a copy of the value to return and
# invoking ++/-- on the original.
print
    map {
        my $op = $_;
        <<"MUTATOR";
    '${op}' => Sub::Name::subname(
        '${op}',
        sub {
            my \$result = $op \$_[$SELF][$TIED_PAYLOAD];
            my \$followup = \$_[$SELF][$CODE]->(
                ' ->($op '
                . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                    ? \$_[$SELF][$UNTIED_PAYLOAD]
                    : 'undef' )
                . ') ->'
                . overload::StrVal(\$result) );
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
MUTATOR
    }
    split ' ',
    $overload::ops{mutators};

# Handle assignment operators plus &=, |=, and ^= from 'binary'.
print
    map {
        my $op = $_;
        <<"ASSIGNMENT";
    '${op}' => Sub::Name::subname(
        '${op}',
        sub {
            \$_[$SELF][$TIED_PAYLOAD] $op \$_[$OTHER];
            my \$followup = \$_[$SELF][$CODE]->(
                '->($op '
                . ( defined \$_[$OTHER]
                    ? \$_[$OTHER]
                    : 'undef' )
                . ') ->'
                . overload::StrVal(\$_[$SELF][$UNTIED_PAYLOAD]) );
            \$_[0] = Devel::Spy->new( \$_[$SELF][$UNTIED_PAYLOAD], \$followup );
        }
    ),
ASSIGNMENT
    }
    grep { /=$/ }
    map split(' '),
    @overload::ops{qw(
        assign
        binary
    )};

# Handle unary and math functions except atan2
print
    map {
        my $op = $_;
        my $actual_op = $op eq 'neg' ? '!' : $op;
        <<"UNARY";
    '${op}' => Sub::Name::subname(
        '${op}',
        sub {
            my \$result = $actual_op \$_[$SELF][$TIED_PAYLOAD];
            my \$followup = \$_[$SELF][$CODE]->(
                " ->($op"
                . ( defined \$_[$SELF][$UNTIED_PAYLOAD]
                    ? \$_[$SELF][$UNTIED_PAYLOAD]
                    : 'undef')
                . ') ->'
                . overload::StrVal(\$result) );
            return Devel::Spy->new( \$result, \$followup );
        }
    ),
UNARY
    }
    grep { $_ ne 'atan2' }
    map split(' '),
    @overload::ops{qw(
        unary
        func
    )};

print <<"FOOTER";
);

overload->import( \@overloading );

# TEST: Verify that all overloadable operations have been overloaded
for my \$category ( sort keys %overload::ops ) {
    my \@ops = split ' ', \$overload::ops{\$category};
    for my \$op ( \@ops ) {
            next if \$category eq 'special' && \$op eq 'nomethod';
            next if \$category eq 'special' && \$op eq 'fallback';

	no strict 'refs';

	next if defined &{"Devel::Spy::_obj::(\$op"};

	warn "Missing op [\$op] from category [\$category]";
    }
}

# Clean up the few things I've generated in this namespace
delete \@Devel::Spy::_obj::{qw(
    BEGIN
    __ANON__
)};

1;
FOOTER