use strict;
use warnings;
package Boilerplater::Binding::Perl::Class;
use Boilerplater::Util qw( verify_args );
our %registry;
sub registry { \%registry }
our %register_PARAMS = (
parcel => undef,
class_name => undef,
bind_methods => undef,
bind_constructors => undef,
make_pod => undef,
xs_code => undef,
client => undef,
);
sub register {
my $either = shift;
verify_args( \%register_PARAMS, @_ ) or confess $@;
my $self = bless { %register_PARAMS, @_, }, ref($either) || $either;
confess("Missing required param 'class_name'")
unless $self->{class_name};
confess("$self->{class_name} already registered")
if exists $registry{ $self->{class_name} };
if ( $self->{bind_methods}
|| $self->{bind_constructors}
|| $self->{make_pod} )
{
$self->{client} = Boilerplater::Class->fetch_singleton(
parcel => $self->{parcel},
class_name => $self->{class_name},
);
confess("Can't fetch singleton for $self->{class_name}")
unless $self->{client};
}
$registry{ $self->{class_name} } = $self;
return $self;
}
sub get_class_name { shift->{class_name} }
sub get_bind_methods { shift->{bind_methods} }
sub get_bind_constructors { shift->{bind_constructors} }
sub get_make_pod { shift->{make_pod} }
sub get_client { shift->{client} }
sub get_xs_code { shift->{xs_code} }
sub constructor_bindings {
my $self = shift;
my @bound = map {
my $xsub = Boilerplater::Binding::Perl::Constructor->new(
class => $self->{client},
alias => $_,
);
} @{ $self->{bind_constructors} };
return @bound;
}
sub method_bindings {
my $self = shift;
my $client = $self->{client};
my $meth_list = $self->{bind_methods};
my @bound;
# Assemble a list of methods to be bound for this class.
my %meth_to_bind;
for my $meth_namespec (@$meth_list) {
my ( $alias, $name )
= $meth_namespec =~ /^(.*?)\|(.*)$/
? ( $1, $2 )
: ( lc($meth_namespec), $meth_namespec );
$meth_to_bind{$name} = { alias => $alias };
}
# Iterate over all this class's methods, stopping to bind each one that
# was spec'd.
for my $method ( $client->methods ) {
my $meth_name = $method->get_macro_sym;
my $bind_args = delete $meth_to_bind{$meth_name};
next unless $bind_args;
# Safety checks against excess binding code or private methods.
if ( !$method->novel ) {
confess( "Binding spec'd for method '$meth_name' in class "
. "$self->{class_name}, but it's overridden and "
. "should be bound via the parent class" );
}
elsif ( $method->private ) {
confess( "Binding spec'd for method '$meth_name' in class "
. "$self->{class_name}, but it's private" );
}
# Create an XSub binding for each override. Each of these directly
# calls the implementing function, rather than invokes the method on
# the object using VTable method dispatch. Doing things this way
# allows SUPER:: invocations from Perl-space to work properly.
for my $descendant ( $client->tree_to_ladder ) { # includes self
my $real_method = $descendant->novel_method( lc($meth_name) );
next unless $real_method;
# Create the binding, add it to the array.
my $method_binding = Boilerplater::Binding::Perl::Method->new(
method => $real_method,
%$bind_args,
);
push @bound, $method_binding;
}
}
# Verify that we processed all methods.
my @leftover_meths = keys %meth_to_bind;
confess("Leftover for $self->{class_name}: '@leftover_meths'")
if @leftover_meths;
return @bound;
}
sub _gen_subroutine_pod {
my ( $self, %args ) = @_;
my ( $func, $sub_name, $class, $code_sample, $class_name )
= @args{qw( func name class sample class_name )};
my $param_list = $func->get_param_list;
my $args = "";
my $num_vars = $param_list->num_vars;
# Only allow "public" subs to be exposed as part of the public API.
confess("$class_name->$sub_name is not public") unless $func->public;
# Get documentation, which may be inherited.
my $docucom = $func->get_docucomment;
if ( !$docucom ) {
my $micro_sym = $func->micro_sym;
my $parent = $class;
while ( $parent = $parent->get_parent ) {
my $parent_func = $parent->method($micro_sym);
last unless $parent_func;
$docucom = $parent_func->get_docucomment;
last if $docucom;
}
}
confess("No DocuComment for '$sub_name' in '$class_name'")
unless $docucom;
if ( $num_vars > 2 or ( $args{is_constructor} && $num_vars > 1 ) ) {
$args = " I<[labeled params]> ";
}
elsif ( $param_list->num_vars ) {
$args = $func->get_param_list->name_list;
$args =~ s/self.*?(?:,\s*|$)//; # kill self param
}
my $pod = "=head2 $sub_name($args)\n\n";
if ( defined($code_sample) && length($code_sample) ) {
$pod .= "$code_sample\n";
}
if ( my $long_doc = $docucom->get_description ) {
$pod .= _perlify_doc_text($long_doc) . "\n\n";
}
# Add params in a list.
my $param_names = $docucom->get_param_names;
my $param_docs = $docucom->get_param_docs;
if (@$param_names) {
$pod .= "=over\n\n";
for ( my $i = 0; $i <= $#$param_names; $i++ ) {
$pod .= "=item *\n\n";
$pod .= "B<$param_names->[$i]> - $param_docs->[$i]\n\n";
}
$pod .= "=back\n\n";
}
# Add return value description, if any.
if ( defined( my $retval = $docucom->get_retval ) ) {
$pod .= "Returns: $retval\n\n";
}
return $pod;
}
sub create_pod {
my $self = shift;
my $pod_args = $self->{make_pod} or return;
my $class = $self->{client} or die "No client for $self->{class_name}";
my $class_name = $class->get_class_name;
my $docucom = $class->get_docucomment;
confess("No DocuComment for '$class_name'") unless $docucom;
my $brief = $docucom->get_brief;
my $description = _perlify_doc_text( $pod_args->{description}
|| $docucom->get_description );
my $synopsis_pod = '';
if ( defined $pod_args->{synopsis} ) {
$synopsis_pod = qq|=head1 SYNOPSIS\n\n$pod_args->{synopsis}\n|;
}
my $constructor_pod = "";
my $constructors = $pod_args->{constructors} || [];
if ( defined $pod_args->{constructor} ) {
push @$constructors, $pod_args->{constructor};
}
if (@$constructors) {
$constructor_pod = "=head1 CONSTRUCTORS\n\n";
for my $spec (@$constructors) {
if ( !ref $spec ) {
$constructor_pod .= _perlify_doc_text($spec);
}
else {
my $func_name = $spec->{func} || 'init';
my $init_func = $class->function($func_name);
my $ctor_name = $spec->{name} || 'new';
my $code_sample = $spec->{sample};
$constructor_pod .= _perlify_doc_text(
$self->_gen_subroutine_pod(
func => $init_func,
name => $ctor_name,
sample => $code_sample,
class => $class,
class_name => $class_name,
is_constructor => 1,
)
);
}
}
}
my @method_docs;
my $methods_pod = "";
my @abstract_method_docs;
my $abstract_methods_pod = "";
for my $spec ( @{ $pod_args->{methods} } ) {
my $meth_name = ref($spec) ? $spec->{name} : $spec;
my $method = $class->method($meth_name);
confess("Can't find method '$meth_name' in class '$class_name'")
unless $method;
my $method_pod;
if ( ref($spec) ) {
$method_pod = $spec->{pod};
}
else {
$method_pod = $self->_gen_subroutine_pod(
func => $method,
name => $meth_name,
sample => '',
class => $class,
class_name => $class_name
);
}
if ( $method->abstract ) {
push @abstract_method_docs, _perlify_doc_text($method_pod);
}
else {
push @method_docs, _perlify_doc_text($method_pod);
}
}
if (@method_docs) {
$methods_pod = join( "", "=head1 METHODS\n\n", @method_docs );
}
if (@abstract_method_docs) {
$abstract_methods_pod = join( "", "=head1 ABSTRACT METHODS\n\n",
@abstract_method_docs );
}
my $child = $class;
my @ancestors;
while ( defined( my $parent = $child->get_parent ) ) {
push @ancestors, $parent;
$child = $parent;
}
my $inheritance_pod = "";
if (@ancestors) {
$inheritance_pod = "=head1 INHERITANCE\n\n";
$inheritance_pod .= $class->get_class_name;
for my $ancestor (@ancestors) {
$inheritance_pod .= " isa L<" . $ancestor->get_class_name . ">";
}
$inheritance_pod .= ".\n";
}
my $pod = <<END_POD;
# Auto-generated file -- DO NOT EDIT!!!!!
=head1 NAME
$class_name - $brief
$synopsis_pod
=head1 DESCRIPTION
$description
$constructor_pod
$methods_pod
$abstract_methods_pod
$inheritance_pod
=head1 COPYRIGHT AND LICENSE
Copyright 2005-2009 Marvin Humphrey
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
END_POD
}
sub _perlify_doc_text {
my $documentation = shift;
# Remove double-equals hack needed to fool perldoc, PAUSE, etc. :P
$documentation =~ s/^==/=/mg;
# Change <code>foo</code> to C<< foo >>.
$documentation =~ s#<code>(.*?)</code>#C<< $1 >>#gsm;
# Lowercase all method names: Open_In() => open_in()
$documentation
=~ s/([A-Z][A-Za-z0-9]*(?:_[A-Z][A-Za-z0-9]*)*\(\))/\L$1\E/gsm;
# Change all instances of NULL to 'undef'
$documentation =~ s/NULL/undef/g;
return $documentation;
}
1;
__END__
__POD__
=head1 NAME
Boilerplater::Binding::Perl::Class - Generate Perl binding code for a
Boilerplater::Class.
=head1 COPYRIGHT AND LICENSE
Copyright 2008-2009 Marvin Humphrey
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
