You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@lucy.apache.org by ma...@apache.org on 2011/12/20 23:46:31 UTC
[lucy-commits] svn commit: r1221510 - in /incubator/lucy/trunk/clownfish: include/CFC.h
perl/lib/Clownfish.xs perl/lib/Clownfish/Binding/Perl.pm
perl/lib/Clownfish/Binding/Perl/Class.pm perl/typemap src/CFCPerlClass.c
src/CFCPerlClass.h
Author: marvin
Date: Tue Dec 20 22:46:30 2011
New Revision: 1221510
URL: http://svn.apache.org/viewvc?rev=1221510&view=rev
Log:
Restore full Perl implementation of CFCPerlClass.
Undo porting of Clownfish::Binding::Perl::Class, restoring to a state of
r1098460, with two changes: 1) The addition of registered() and singleton(),
and 2) application of the fix for LUCY-181.
Removed:
incubator/lucy/trunk/clownfish/src/CFCPerlClass.c
incubator/lucy/trunk/clownfish/src/CFCPerlClass.h
Modified:
incubator/lucy/trunk/clownfish/include/CFC.h
incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Class.pm
incubator/lucy/trunk/clownfish/perl/typemap
Modified: incubator/lucy/trunk/clownfish/include/CFC.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/include/CFC.h?rev=1221510&r1=1221509&r2=1221510&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/include/CFC.h (original)
+++ incubator/lucy/trunk/clownfish/include/CFC.h Tue Dec 20 22:46:30 2011
@@ -41,7 +41,6 @@
#include "CFCPerlSub.h"
#include "CFCPerlMethod.h"
-#include "CFCPerlClass.h"
#include "CFCPerlConstructor.h"
#include "CFCPerlPod.h"
#include "CFCPerlTypeMap.h"
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs?rev=1221510&r1=1221509&r2=1221510&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs Tue Dec 20 22:46:30 2011
@@ -1851,94 +1851,6 @@ CODE:
OUTPUT: RETVAL
-MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Class
-
-SV*
-_new(parcel, class_name, client, xs_code_sv, pod_spec)
- CFCParcel *parcel;
- const char *class_name;
- CFCClass *client;
- SV *xs_code_sv;
- CFCPerlPod *pod_spec;
-CODE:
- const char *xs_code = SvOK(xs_code_sv)
- ? SvPV_nolen(xs_code_sv)
- : NULL;
- CFCPerlClass *self
- = CFCPerlClass_new(parcel, class_name, client, xs_code, pod_spec);
- RETVAL = S_cfcbase_to_perlref(self);
- CFCBase_decref((CFCBase*)self);
-OUTPUT: RETVAL
-
-void
-_destroy(self)
- CFCPerlClass *self;
-PPCODE:
- CFCBase_decref((CFCBase*)self);
-
-void
-_add_to_registry(self)
- CFCPerlClass *self;
-PPCODE:
- CFCPerlClass_add_to_registry(self);
-
-SV*
-singleton(unused_sv, class_name)
- SV *unused_sv;
- const char *class_name;
-CODE:
- CFCPerlClass *binding = CFCPerlClass_singleton(class_name);
- RETVAL = S_cfcbase_to_perlref(binding);
-OUTPUT: RETVAL
-
-SV*
-registered(...)
-CODE:
- CFCPerlClass **registry = CFCPerlClass_registry();
- RETVAL = S_array_of_cfcbase_to_av((CFCBase**)registry);
-OUTPUT: RETVAL
-
-void
-_clear_registry(...)
-PPCODE:
- CFCPerlClass_clear_registry();
-
-void
-_set_or_get(self, ...)
- CFCPerlClass *self;
-ALIAS:
- get_class_name = 2
- get_client = 4
- get_xs_code = 6
- get_pod_spec = 8
-PPCODE:
-{
- START_SET_OR_GET_SWITCH
- case 2: {
- const char *value = CFCPerlClass_get_class_name(self);
- retval = newSVpvn(value, strlen(value));
- }
- break;
- case 4: {
- CFCClass *value = CFCPerlClass_get_client(self);
- retval = S_cfcbase_to_perlref(value);
- }
- break;
- case 6: {
- const char *value = CFCPerlClass_get_xs_code(self);
- retval = value
- ? newSVpvn(value, strlen(value))
- : newSV(0);
- }
- break;
- case 8: {
- CFCPerlPod *value = CFCPerlClass_get_pod_spec(self);
- retval = S_cfcbase_to_perlref(value);
- }
- break;
- END_SET_OR_GET_SWITCH
-}
-
MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Pod
SV*
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl.pm?rev=1221510&r1=1221509&r2=1221510&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl.pm Tue Dec 20 22:46:30 2011
@@ -325,7 +325,7 @@ sub prepare_pod {
my $registered = Clownfish::Binding::Perl::Class->registered;
$has_pod{ $_->get_class_name } = 1
- for grep { $_->get_pod_spec } @$registered;
+ for grep { $_->get_make_pod } @$registered;
for my $class (@$ordered) {
my $class_name = $class->get_class_name;
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Class.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Class.pm?rev=1221510&r1=1221509&r2=1221510&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Class.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Class.pm Tue Dec 20 22:46:30 2011
@@ -17,11 +17,12 @@ use strict;
use warnings;
package Clownfish::Binding::Perl::Class;
-use base qw( Clownfish::Base );
use Clownfish::Util qw( verify_args );
-use Clownfish::Binding::Perl::Pod;
use Carp;
+our %registry;
+sub registry { \%registry }
+
our %register_PARAMS = (
parcel => undef,
class_name => undef,
@@ -32,79 +33,61 @@ our %register_PARAMS = (
client => undef,
);
-our %bind_methods;
-our %bind_constructors;
-
sub register {
- my ( $either, %args ) = @_;
- verify_args( \%register_PARAMS, %args ) or confess $@;
- $args{parcel} = Clownfish::Parcel->acquire( $args{parcel} );
+ my $either = shift;
+ verify_args( \%register_PARAMS, @_ ) or confess $@;
+ my $self = bless { %register_PARAMS, @_, }, ref($either) || $either;
# Validate.
confess("Missing required param 'class_name'")
- unless $args{class_name};
+ unless $self->{class_name};
+ confess("$self->{class_name} already registered")
+ if exists $registry{ $self->{class_name} };
# Retrieve Clownfish::Class client, if it will be needed.
- my $client;
- if ( $args{bind_methods}
- || $args{bind_constructors}
- || $args{make_pod} )
+ if ( $self->{bind_methods}
+ || $self->{bind_constructors}
+ || $self->{make_pod} )
{
- $args{client} = Clownfish::Class->fetch_singleton(
- parcel => $args{parcel},
- class_name => $args{class_name},
+ $self->{client} = Clownfish::Class->fetch_singleton(
+ parcel => $self->{parcel},
+ class_name => $self->{class_name},
);
- confess("Can't fetch singleton for $args{class_name}")
- unless $args{client};
- }
-
- # Create Pod spec if needed.
- my $pod_spec;
- if ( $args{make_pod} ) {
- $pod_spec
- = Clownfish::Binding::Perl::Pod->new( %{ $args{make_pod} } );
+ confess("Can't fetch singleton for $self->{class_name}")
+ unless $self->{client};
}
- # Create object.
- my $self = _new( @args{qw( parcel class_name client xs_code pod_spec )} );
- $bind_methods{$$self} = $args{bind_methods};
- $bind_constructors{$$self} = $args{bind_constructors};
-
# Add to registry.
- _add_to_registry($self);
+ $registry{ $self->{class_name} } = $self;
return $self;
}
-sub DESTROY {
- return; # Leak intentionally for now.
- my $self = shift;
- delete $bind_methods{$$self};
- delete $bind_constructors{$$self};
- _destroy($self);
-}
-
-END { __PACKAGE__->_clear_registry }
+sub registered { [ values %registry ] }
+sub singleton { $registry{ $_[1] } }
-sub get_bind_methods { $bind_methods{ ${ +shift } } }
-sub get_bind_constructors { $bind_constructors{ ${ +shift } } }
+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 = Clownfish::Binding::Perl::Constructor->new(
- class => $self->get_client,
+ class => $self->{client},
alias => $_,
);
- } @{ $self->get_bind_constructors };
+ } @{ $self->{bind_constructors} };
return @bound;
}
sub method_bindings {
- my $self = shift;
- my $client = $self->get_client;
- my $meth_list = $self->get_bind_methods;
- my $class_name = $self->get_class_name;
+ 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.
@@ -127,12 +110,12 @@ sub method_bindings {
# Safety checks against excess binding code or private methods.
if ( !$method->novel ) {
confess( "Binding spec'd for method '$meth_name' in class "
- . "$class_name, but it's overridden and "
+ . "$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 "
- . "$class_name, but it's private" );
+ . "$self->{class_name}, but it's private" );
}
# Create an XSub binding for each override. Each of these directly
@@ -154,34 +137,163 @@ sub method_bindings {
# Verify that we processed all methods.
my @leftover_meths = keys %meth_to_bind;
- confess("Leftover for $class_name: '@leftover_meths'")
+ 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;
+
+ # Build string summarizing arguments to use in header.
+ 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
+ }
+
+ # Add code sample.
+ my $pod = "=head2 $sub_name($args)\n\n";
+ if ( defined($code_sample) && length($code_sample) ) {
+ $pod .= "$code_sample\n";
+ }
+
+ # Incorporate "description" text from DocuComment.
+ 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_spec = $self->get_pod_spec or return;
- my $class_name = $self->get_class_name;
- my $class = $self->get_client or die "No client for $class_name";
+ 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 = $pod_spec->_perlify_doc_text( $pod_spec->get_description
- || $docucom->get_long );
+ my $brief = $docucom->get_brief;
+ my $description
+ = _perlify_doc_text( $pod_args->{description} || $docucom->get_long );
# Create SYNOPSIS.
- my $synopsis_pod = $pod_spec->get_synopsis;
- if ($synopsis_pod) {
- $synopsis_pod = qq|=head1 SYNOPSIS\n\n$synopsis_pod\n|;
+ my $synopsis_pod = '';
+ if ( defined $pod_args->{synopsis} ) {
+ $synopsis_pod = qq|=head1 SYNOPSIS\n\n$pod_args->{synopsis}\n|;
}
# Create CONSTRUCTORS.
- my $constructor_pod = $pod_spec->constructors_pod($class);
+ 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,
+ )
+ );
+ }
+ }
+ }
# Create METHODS, possibly including an ABSTRACT METHODS section.
- my $methods_pod = $pod_spec->methods_pod($class);
+ 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 );
+ }
# Build an INHERITANCE section describing class ancestry.
my $child = $class;
@@ -195,14 +307,14 @@ sub create_pod {
$inheritance_pod = "=head1 INHERITANCE\n\n";
$inheritance_pod .= $class->get_class_name;
for my $ancestor (@ancestors) {
- my $class_name = $ancestor->get_class_name;
- if ( __PACKAGE__->singleton($class_name) ) {
+ my $class_name = $ancestor->get_class_name;
+ if ( $registry{$class_name} ) {
$inheritance_pod .= " isa L<$class_name>";
- }
+ }
else {
$inheritance_pod .= " isa $class_name";
}
- }
+ }
$inheritance_pod .= ".\n";
}
@@ -237,6 +349,8 @@ $description
$constructor_pod
+$abstract_methods_pod
+
$methods_pod
$inheritance_pod
@@ -252,6 +366,28 @@ END_POD
return $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;
+
+ # Change "Err_error" to "Lucy->error".
+ $documentation =~ s/Err_error/Lucy->error/g;
+
+ return $documentation;
+}
+
1;
__END__
@@ -307,21 +443,19 @@ the source code.)
=back
-=head2 singleton
-
- my $binding = Clownfish::Binding::Perl::Class->singleton($class_name);
-
-Given a class name, return a class binding if one exists.
+=head1 registry
-=head2 registered
-
- my $registered = Clownfish::Binding::Perl::Class->registered;
+ my $registry = Clownfish::Binding::Perl::Class->registry;
+ while ( my $class_name, $class_binding ) = each %$registry ) {
+ ...
+ }
-All registered bindings.
+Return the hash registry used by register(). The keys are class names, and
+the values are Clownfish::Binding::Perl::Class objects.
=head1 OBJECT METHODS
-=head2 get_class_name get_bind_methods get_bind_methods get_pod_spec
+=head2 get_class_name get_bind_methods get_bind_methods get_make_pod
get_xs_code get_client
Accessors. C<get_client> retrieves the Clownfish::Class module to be
@@ -348,3 +482,4 @@ the C<bind_methods> spec.
Auto-generate POD according to the make_pod spec, if such a spec was supplied.
=cut
+
Modified: incubator/lucy/trunk/clownfish/perl/typemap
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/typemap?rev=1221510&r1=1221509&r2=1221510&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/typemap (original)
+++ incubator/lucy/trunk/clownfish/perl/typemap Tue Dec 20 22:46:30 2011
@@ -33,7 +33,6 @@ CFCVariable* CLOWNFISH_TYPE
CFCBindCore* CLOWNFISH_BINDING_CORE
CFCBindClass* CLOWNFISH_BINDING_CORE_TYPE
CFCPerlSub* CLOWNFISH_BINDING_PERL_SUBROUTINE
-CFCPerlClass* CLOWNFISH_BINDING_PERL_COMMON
CFCPerlConstructor* CLOWNFISH_BINDING_PERL_COMMON
CFCPerlMethod* CLOWNFISH_BINDING_PERL_COMMON
CFCPerlPod* CLOWNFISH_BINDING_PERL_COMMON