#!/usr/bin/perl
use strict;
use warnings;
use autodie;
# We want to make sure that when we load an exception class we're getting the
# version for the release-to-be, not the installed version.
use blib;
use Module::Runtime qw( use_module );
use Moose::Util qw( english_list find_meta );
use Path::Tiny qw( path );
sub main {
my $exception_dir = path(qw( lib Moose Exception ));
my @classes;
my $iter = $exception_dir->iterator();
while ( my $file = $iter->() ) {
next if $file->is_dir();
my ($class) = $file =~ m{.*(Moose/Exception/.+)\.pm};
$class =~ s{/}{::}g;
use_module($class) or next;
push @classes, $class;
}
print_header();
for my $class (sort @classes) {
print_class_manifest($class);
}
print_footer();
}
sub print_header {
print <<'EOF';
=head1 DESCRIPTION
This document contains a manifest of all the exception classes that are thrown
as Moose internal errors.
=head1 COMMON ELEMENTS
Unless otherwise stated, all classes are subclasses of L<Moose::Exception>.
Similarly, all classes provide the following attribute reader methods:
=head2 $exception->message
This method returns the error message for the exception.
=head2 $exception->trace
This method returns a L<Devel::StackTrace> object.
=head1 EXCEPTION CLASSES
Moose ships with the following exception classes:
EOF
}
sub print_class_manifest {
my $class = shift;
my $meta = find_meta($class) or return;
print '=head2 ' . $class . "\n\n";
my $superclass_text = _superclass_text_for($meta);
my $role_text = _role_text_for($meta);
if ($superclass_text || $role_text) {
print join q{ }, grep { defined } $superclass_text, $role_text;
print "\n\n";
}
print _attribute_text_for($meta);
print "\n";
}
sub _superclass_text_for {
my $meta = shift;
my @superclasses = $meta->superclasses();
if ( !@superclasses ) {
die $meta->name . ' does not have any superclasses!';
}
return unless @superclasses > 1 || $superclasses[0] ne 'Moose::Exception';
return
'This class is a subclass of '
. linked_english_list(@superclasses) . '.';
}
sub _role_text_for {
my $meta = shift;
# The individual members of composite roles will also show up individually
# in the return value of calculate_all_roles()
my @roles = sort { $a cmp $b }
grep { !/\|/ }
map { $_->name() } $meta->calculate_all_roles();
return unless @roles;
# Change to linked_english_list if we ever add POD for each exception role.
my $role_noun = @roles > 1 ? 'roles' : 'role';
return 'This class consumes the ' . english_list(@roles) . " $role_noun.";
}
my %common = map { $_ => 1 } qw( message trace );
sub _attribute_text_for {
my $meta = shift;
for my $attr_name ( keys %common ) {
unless ( $meta->find_attribute_by_name($attr_name) ) {
die $meta->name . " has no $attr_name attribute!";
}
}
my @attributes = sort { $a->name() cmp $b->name() }
grep { !$common{ $_->name() } } $meta->get_all_attributes();
unless (@attributes) {
return "This class has no attributes except for C<message> and C<trace()>.\n";
}
my $text = "This class has the following methods:\n\n";
$text .= "=over 4\n\n";
for my $attr (@attributes) {
$text .= _one_attribute_text( $meta, $attr );
}
$text .= "=back\n";
return $text;
}
sub _one_attribute_text {
my $meta = shift;
my $attr = shift;
my $text = q{};
if ( my $reader = $attr->get_read_method() ) {
$text = '=item * $exception->' . "$reader()\n\n";
if ( $attr->has_type_constraint() ) {
$text .= _type_constraint_text($attr);
}
}
elsif ( $attr->has_handles() ) {
for my $method ( %{ $attr->handles() } ) {
$text .= '=item * $exception->' . "$method()\n\n";
}
}
else {
die 'no read method name or handles for '
. $attr->name() . ' in '
. $meta->name() . '!';
}
if ( $attr->has_documentation() ) {
my $doc = $attr->documentation();
# This ensures that code sections in the documentation are separated
# from preceding text.
$doc =~ s/\n /\n\n /;
$text .= "$doc\n\n";
}
return $text;
}
sub _type_constraint_text {
my $attr = shift;
my $tc = $attr->type_constraint();
return q{} if $tc->name() eq 'Any';
my $tc_name;
if ( $tc->isa('Moose::Meta::TypeConstraint::Class') ) {
$tc_name = 'L<' . $tc->class() . '> object';
}
elsif ( $tc->isa('Moose::Meta::TypeConstraint::Role') ) {
$tc_name = 'object which does the L<' . $tc->class() . '> role';
}
else {
$tc_name = $tc->name() . ' value';
}
my $preposition = $tc_name =~ /^[aeiou]/i ? 'an' : 'a';
return "Returns $preposition $tc_name.\n\n";
}
sub linked_english_list {
my @items = @_;
return unless @items;
return english_list( map {"L<$_>"} @items );
}
sub print_footer {
print "=cut\n";
}
main();