Devel-OverloadInfo-0.002HEADDevel-OverloadInfo-0.002master

1 files changed, 192 insertions, 0 deletions

diff --git a/lib/Devel/OverloadInfo.pm b/lib/Devel/OverloadInfo.pm
new file mode 100644
index 0000000..2e06978
--- /dev/null
+++ b/lib/Devel/OverloadInfo.pm
@@ -0,0 +1,192 @@
+package Devel::OverloadInfo;
+$Devel::OverloadInfo::VERSION = '0.002';
+# ABSTRACT: introspect overloaded operators
+
+# =head1 DESCRIPTION
+#
+# Devel::OverloadInfo returns information about L<overloaded|overload>
+# operators for a given class (or object), including where in the
+# inheritance hierarchy the overloads are declared and where the code
+# implementing it is.
+#
+# =cut
+
+use strict;
+use warnings;
+use overload ();
+use Scalar::Util qw(blessed);
+use Sub::Identify qw(sub_fullname);
+use Package::Stash 0.14;
+use MRO::Compat;
+
+use Exporter 5.57 qw(import);
+our @EXPORT_OK = qw(overload_info);
+
+sub stash_with_symbol {
+    my ($class, $symbol) = @_;
+
+    for my $package (@{mro::get_linear_isa($class)}) {
+        my $stash = Package::Stash->new($package);
+        my $value_ref = $stash->get_symbol($symbol);
+        return ($stash, $value_ref) if $value_ref;
+    }
+    return;
+}
+
+# =func overload_info
+#
+#     my $info = overload_info($class_or_object);
+#
+# Returns a hash reference with information about all the overloaded
+# operators of the argument, which can be either a class name or a blessed
+# object. The keys are the overloaded operators, as specified in
+# C<%overload::ops> (see L<overload/Overloadable Operations>).
+#
+# =over
+#
+# =item class
+#
+# The name of the class in which the operator overloading was declared.
+#
+# =item code
+#
+# A reference to the function implementing the overloaded operator.
+#
+# =item code_name
+#
+# The name of the function implementing the overloaded operator, as
+# returned by C<sub_fullname> in L<Sub::Identify>.
+#
+# =item method_name (optional)
+#
+# The name of the method implementing the overloaded operator, if the
+# overloading was specified as a named method, e.g. C<< use overload $op
+# => 'method'; >>.
+#
+# =item code_class (optional)
+#
+# The name of the class in which the method specified by C<method_name>
+# was found.
+#
+# =item value (optional)
+#
+# For the special C<fallback> key, the value it was given in C<class>.
+#
+# =back
+#
+# =cut
+
+sub overload_info {
+    my $class = blessed($_[0]) || $_[0];
+
+    return undef unless overload::Overloaded($class);
+
+    my (%overloaded);
+    for my $op (map split(/\s+/), values %overload::ops) {
+        my $op_method = $op eq 'fallback' ? "()" : "($op";
+        my ($stash, $func) = stash_with_symbol($class, "&$op_method")
+            or next;
+        my $info = $overloaded{$op} = {
+            class => $stash->name,
+        };
+        if ($func == \&overload::nil) {
+            # Named method or fallback, stored in the scalar slot
+            if (my $value_ref = $stash->get_symbol("\$$op_method")) {
+                my $value = $$value_ref;
+                if ($op eq 'fallback') {
+                    $info->{value} = $value;
+                } else {
+                    $info->{method_name} = $value;
+                    if (my ($impl_stash, $impl_func) = stash_with_symbol($class, "&$value")) {
+                        $info->{code_class} = $impl_stash->name;
+                        $info->{code} = $impl_func;
+                    }
+                }
+            }
+        } else {
+            $info->{code} = $func;
+        }
+        $info->{code_name} = sub_fullname($info->{code})
+            if exists $info->{code};
+    }
+    return \%overloaded;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Devel::OverloadInfo - introspect overloaded operators
+
+=head1 VERSION
+
+version 0.002
+
+=head1 DESCRIPTION
+
+Devel::OverloadInfo returns information about L<overloaded|overload>
+operators for a given class (or object), including where in the
+inheritance hierarchy the overloads are declared and where the code
+implementing it is.
+
+=head1 FUNCTIONS
+
+=head2 overload_info
+
+    my $info = overload_info($class_or_object);
+
+Returns a hash reference with information about all the overloaded
+operators of the argument, which can be either a class name or a blessed
+object. The keys are the overloaded operators, as specified in
+C<%overload::ops> (see L<overload/Overloadable Operations>).
+
+=over
+
+=item class
+
+The name of the class in which the operator overloading was declared.
+
+=item code
+
+A reference to the function implementing the overloaded operator.
+
+=item code_name
+
+The name of the function implementing the overloaded operator, as
+returned by C<sub_fullname> in L<Sub::Identify>.
+
+=item method_name (optional)
+
+The name of the method implementing the overloaded operator, if the
+overloading was specified as a named method, e.g. C<< use overload $op
+=> 'method'; >>.
+
+=item code_class (optional)
+
+The name of the class in which the method specified by C<method_name>
+was found.
+
+=item value (optional)
+
+For the special C<fallback> key, the value it was given in C<class>.
+
+=back
+
+=head1 AUTHOR
+
+Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2014 by Dagfinn Ilmari Mannsåker.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut