object
Returns the object type for this class, which is {object} EOT }, };
my $other_methods = { author => { dir => { code => "sub dir { return( shift->links->cpan_directory( \@_ ) ); }\n", pod => <<EOT, =head2 dir
Sets or gets the cpan_directory link property.
This is actually a shortcut to accessing the property cpan_directory in "links"
It returns an URI object, or undef if no value is set. EOT type => 'string', }, metacpan_url => { code => <<EOT, sub metacpan_url { my \$self = shift( \@_ ); my \$pauseid = \$self->pauseid || return( \$self->error( "No pause ID is set to return a Meta CPAN URL for this author." ) ); my \$api_uri = \$self->api->api_uri->clone; \$api_uri->path( "/author/\$pauseid" ); return( \$api_uri ); } EOT pod => <<EOT, =head2 metacpan_url
Returns a link, as an URI object, to the author's page on MetaCPAN, or undef if no pauseid is currently set. EOT type => 'uri', class => 'URI', }, releases => { code => <<EOT, # Taken from MetaCPAN::Client::Author for compatibility sub releases { my \$self = shift( \@_ ); my \$id = \$self->pauseid; return( \$self->api->release({ all => [ { author => \$id }, { status => 'latest' }, ] }) ); } EOT pod => <<EOT, =head2 releases
Returns an ${base_class}::ResultSet oject containing all the author latest releases as release objects. EOT type => 'object', class => "${base_class}::List", }, }, distribution => { metacpan_url => { code => <<EOT, sub metacpan_url { my \$self = shift( \@_ ); my \$name = \$self->name || return( \$self->error( "No distribution name is set to return a Meta CPAN URL for this distribution." ) ); my \$api_uri = \$self->api->api_uri->clone; \$api_uri->path( "/release/\$name" ); return( \$api_uri ); } EOT pod => <<EOT, =head2 metacpan_url
Returns a link, as an URI object, to the distribution's page on MetaCPAN, or undef if no distribution name is currently set. EOT type => 'uri', class => 'URI', }, github => { code => "sub github { return( shift->bugs->github ); }\n", pod => <<EOT, =head2 github
Returns the object for the dynamic class ${base_class}::Bugs::Github, which provides access to a few methods.
See "bugs" for more information.
It returns undef if no value is set. EOT type => 'object', }, rt => { code => "sub rt { return( shift->bugs->rt ); }\n", pod => <<EOT, =head2 rt
Returns the object for the dynamic class ${base_class}::Bugs::Rt, which provides access to a few methods.
See "bugs" for more information.
It returns undef if no value is set. EOT type => 'object', }, }, module => { metacpan_url => { code => <<EOT, sub metacpan_url { my \$self = shift( \@_ ); my \$author = \$self->author || return( \$self->error( "No module author is set to return a Meta CPAN URL for this module." ) ); my \$release = \$self->release || return( \$self->error( "No module release is set to return a Meta CPAN URL for this module." ) ); my \$path = \$self->path || return( \$self->error( "No module path is set to return a Meta CPAN URL for this module." ) ); my \$api_uri = \$self->api->api_uri->clone; \$api_uri->path( "/pod/\$author/\$release/\$path" ); return( \$api_uri ); } EOT pod => <<EOT, =head2 metacpan_url
Returns a link, as an URI object, to the module's page on MetaCPAN, or undef if no module author, release. or path is currently set. EOT type => 'uri', class => 'URI', }, package => { code => <<EOT, sub package { my \$self = shift( \@_ ); my \$doc = \$self->documentation || return( \$self->error( "No documentation module class is set to call ${base_class}->package" ) ); my \$result = \$self->api->package( \$doc ) || return( \$self->pass_error ); return( \$result ); } EOT pod => <<EOT, =head2 package
Returns an ${base_class}::Package object for this module, or upon error, sets an error object and returns undef in scalar context or an empty list in list context.
An error is returned if the documentation property is not set. EOT type => 'object', }, permission => { code => <<EOT, sub permission { my \$self = shift( \@_ ); my \$doc = \$self->documentation || return( \$self->error( "No documentation module class is set to call ${base_class}->package" ) ); my \$result = \$self->api->permission( \$doc ) || return( \$self->pass_error ); return( \$result ); } EOT pod => <<EOT, =head2 permission
Returns an ${base_class}::Permission object for this module, or upon error, sets an error object and returns undef in scalar context or an empty list in list context.
An error is returned if the documentation property is not set. EOT type => 'object', }, }, };
# NOTE: special methods definition my $special_methods = { distribution => { _init_preprocess => <<'EOT', sub { my $this = shift( @_ ); if( $self->_is_array( $this ) ) { for( my $i = 0; $i < scalar( @$this ); $i += 2 ) { if( $this->[$i] eq 'bugs' ) { my $ref = $this->[$i + 1]; if( ref( $ref ) eq 'HASH' && exists( $ref->{rt} ) && ref( $ref->{rt} ) eq 'HASH' && exists( $ref->{rt}->{new} ) ) { $ref->{rt}->{recent} = CORE::delete( $ref->{rt}->{new} ); $this->[$i + 1] = $ref; } } } } elsif( $self->_is_hash( $this ) ) { if( exists( $this->{bugs} ) && ref( $this->{bugs} ) eq 'HASH' && exists( $this->{bugs}->{rt} ) && ref( $this->{bugs}->{rt} ) eq 'HASH' && exists( $this->{bugs}->{rt}->{new} ) ) { $this->{bugs}->{rt}->{recent} = CORE::delete( $this->{bugs}->{rt}->{new} ); } } return( $this ); }; EOT }, author => { # There is an inconsistency for the property perlmongers whereby the endpoint /author/by_user will return an hash but others will return an array of hash reference. _init_preprocess => <<'EOT', sub { my $this = shift( @_ ); if( $self->_is_hash( $this ) ) { if( exists( $this->{perlmongers} ) && ref( $this->{perlmongers} ) eq 'HASH' ) { $this->{perlmongers} = [$this->{perlmongers}]; } } return( $this ); }; EOT } };
# Which class is extended by which other class my $extends = { changes => 'file', module => 'file', };
my $pod_more = { package => { version => <<EOT, Please note that this represents the numified version of the module version number. In other object classes, the property version_numified is used instead. For the version object of the module, see "dist_version" EOT }, release_recent => { __description => <<EOT, This class serve to retrieve and manipulate recent releases. EOT } };
# To explicitly set the module name, but only its trailing part, since it will be appended to the top module name (Net::API::CPAN) my $module_names = { changes_release => 'Changes::Release', release_recent => 'Release::Recent', suggest => 'Release::Suggest', };
# For the properties that simply cannot be used as-is as word, we use a dictionary map # Example: # "Sets or gets an array of providess" -> "Sets or gets an array of module class name" my $property_to_word = { provides => 'module class name', };
my $default_value = { version => "''", };
foreach my $object ( sort( keys( %$specs ) ) ) { my $module_name = exists( $module_names->{ $object } ) ? $module_names->{ $object } : join( '', map( ucfirst( lc( $_ ) ), split( /_/, $object ) ) ); ( my $module_path = $module_name ) =~ s,::,/,g; $module_path .= '.pm'; # my @parts = split( /::/, $module_name ); # $module_path .= join( '/', @parts ) . '.pm'; my $module_class = join( '::', $base_class, $module_name ); # my $mod_file = $mod_dir->child( "$module_name.pm" ); my $mod_file = $mod_dir->child( $module_path ); $mod_file->parent->mkpath if( !$mod_file->parent->exists ); ( my $actual_mod_path = $module_class ) =~ s,::,/,g; my $actual_mod_file = $lib_dir->child( "${actual_mod_path}.pm" ); my $module_version = $modules_version; say "\tChecking actual module $module_class file $actual_mod_file for version change."; if( $actual_mod_file->exists ) { say "\tModule file $actual_mod_file exists, trying to get its version number."; # try-catch local $@; my $this_version = eval { no strict 'refs'; require( "$actual_mod_file" ); return( ${"${module_class}::VERSION"} ); }; if( $@ ) { say "\tModule ${module_class} file $actual_mod_file has some error: $@"; } else { say "\tModule $module_name is using version $this_version, using it instead of $modules_version" if( $this_version ne $modules_version ); $module_version = $this_version; } } my $parent = "${base_class}::Generic"; my $parent_specs; my $object_plural = ( substr( $object, -1, 1 ) eq 's' ? $object : $object . 's' ); # if( index( $module_name, '::' ) != -1 ) # { # my @parts = split( /::/, $module_name ); # # Skip the last one that forms our module name and retain the rest that constitutes the parent directory(ie) # my $this_name = pop( @parts ); # my $module_parent_dir = $mod_dir->child( join( '/', @parts ) ); # $module_parent_dir->mkpath if( !$module_parent_dir->exists ); # $mod_file = $module_parent_dir->child( "${this_name}.pm" ); # }
if( exists( $extends->{ $object } ) )
{
$parent_specs = $specs->{ $extends->{ $object } } ||
die( "There is no object '", $extends->{ $object }, "' to extends object '$object' in CPAN API specifications ($api_specs)." );
$parent = "${base_class}::" . join( '', map( ucfirst( lc( $_ ) ), split( /_/, $extends->{ $object } ) ) );
say "\tClass $object inherits from ", $extends->{ $object };
}
my $methods = $specs->{ $object };
my $all_methods = Module::Generic::Array->new( [keys( %$methods )] );
if( exists( $other_methods->{ $object } ) )
{
$all_methods->push( keys( %{$other_methods->{ $object }} ) );
}
if( scalar( keys( %$core_methods ) ) )
{
$all_methods->push( keys( %$core_methods ) );
}
my $sample_file = $base_dir->child( "$object.json" );
my $sample_data;
$sample_data = $sample_file->load_json( boolean_values => [\0, \1] ) if( $sample_file->exists );
my $synop = Module::Generic::Array->new;
if( defined( $sample_data ) )
{
my $args_string = &dump_this( $sample_data );
$synop->push( "my \$obj = ${base_class}::${module_name}->new( $args_string ) || die( ${base_class}::${module_name}->error );\n" );
}
my $lines = Module::Generic::Array->new;
my $pod = Module::Generic::Array->new;
my $code = <<EOT;
##----------------------------------------------------------------------------
## Meta CPAN API - ~/lib/Net/API/CPAN/${module_path}
## Version ${module_version}
## Copyright(c) ${year} DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack\@deguest.jp>
## Created $modules_created
## Modified $today
## All rights reserved
##
##
## This program is free software; you can redistribute it and/or modify it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
# This module file has been automatically generated. Any change made here will be lost.
# Edit the script in ./build/build_modules.pl instead
package ${module_class};
BEGIN
{
use strict;
use warnings;
use parent qw( ${parent} );
use vars qw( \$VERSION );
our \$VERSION = '${module_version}';
};use strict; use warnings;
sub init { my \$self = shift( \@_ ); EOT
my $test_file = $test_dir->child( sprintf( '%03d_%s.t', ++$test_num, $object ) );
my $test_content = <<EOT;
#!perl
# This test file has been automatically generated. Any change made here will be lost.
# Edit the script in ./build/build_modules.pl instead
BEGIN
{
use strict;
use warnings;
use lib './lib';
use vars qw( \$DEBUG );
use Test::More qw( no_plan );
use Module::Generic;
use Scalar::Util ();
our \$DEBUG = exists( \$ENV{AUTHOR_TESTING} ) ? \$ENV{AUTHOR_TESTING} : 0;
};BEGIN { use_ok( '${module_class}' ); };
use strict; use warnings;
my \$test_data = Module::Generic->new->new_json->decode( join( '', <DATA> ) ); \$test_data->{debug} = \$DEBUG; my \$this; my \$obj = ${module_class}->new( \$test_data ); isa_ok( \$obj => '${module_class}' ); if( !defined( \$obj ) ) { BAIL_OUT( ${module_class}->error ); }
# To generate this list: # egrep -E '^sub ' ./lib/Net/API/CPAN/${module_name}.pm | perl -lnE 'my \$m = [split(/\\s+/, \$_)]->[1]; say "can_ok( \\\$obj, ''\$m'' );"' EOT
my $max = 0;
# foreach my $meth ( keys( %$methods ) )
foreach my $meth ( sort( @$all_methods ) )
{
$max = length( $meth ) if( length( $meth ) > $max );
$test_content .= <<EOT;
can_ok( \$obj, '${meth}' );
EOT
}
$test_content .= "\n";
# + 2 (1 for each curly bracket surrounding the property name
$max += 2;
my $methods_list = [];
# foreach my $meth ( sort( keys( %$methods ) ) )
foreach my $meth ( sort( @$all_methods ) )
{
say "Building $object -> $meth";
# The term to use in the POD for this method (a.k.a. property)
my $prop_term = exists( $property_to_word->{ $meth } ) ? $property_to_word->{ $meth } : $meth;
my $prop_term_plural = ( substr( $prop_term, -1, 1 ) eq 's' ? $prop_term : $prop_term . 's' );
my $default = exists( $default_value->{ $meth } ) ? $default_value->{ $meth } : 'undef';
if( exists( $other_methods->{ $object }->{ $meth } ) )
{
die( "No pod documentation for extra method $meth in object $object" ) if( !exists( $other_methods->{ $object }->{ $meth }->{pod} ) );
my $other_def = $other_methods->{ $object }->{ $meth };
# say "# Adding pod for method $meth in object $object -> $other_methods->{ $object }->{ $meth }->{pod}";
$lines->push( $other_def->{code} );
$pod->push( $other_def->{pod} );
my $other_type = $other_def->{type};
if( $other_type eq 'object' )
{
$synop->push( "my \$this = \$obj->${meth};" );
}
else
{
$synop->push( "my \$${other_type} = \$obj->${meth};" );
}
next;
}
elsif( exists( $core_methods->{ $meth } ) )
{
if( $meth eq 'object' )
{
$code .= sprintf( " \$self->%-*s = '$object';\n", $max, "\{${meth}\}" );
}
else
{
$code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" );
}
$synop->push( "my \$str = \$obj->${meth};" );
$lines->push( $core_methods->{ $meth }->{code} );
my $pod_text = $core_methods->{ $meth }->{pod};
$pod_text =~ s/\{object\}/$object/gs;
$pod->push( $pod_text );
next;
}
push( @$methods_list, $meth );
my $def = $methods->{ $meth };
my $type = $def->{type} || die( "No type is defined for method $meth in object $object\n" );
my $example = '';
my $sample_data_string;
if( exists( $sample_data->{ $meth } ) )
{
# Even if this is a simple string, Data::Dumper::Concise will set the surrounding quotes appropriately
$sample_data_string = &dump_this( $sample_data->{ $meth } );
# $sample_data_string = Data::Dumper::Concise::Dumper( $sample_data->{ $meth } );
# $sample_data_string =~ s/\n$//gs;
if( index( $sample_data_string, "\n" ) != -1 )
{
my @sample_lines = split( /\n/, $sample_data_string );
# We start from 1 on purpose
for( my $i = 1; $i < scalar( @sample_lines ); $i++ )
{
substr( $sample_lines[$i], 0, 0, ' ' );
}
$sample_data_string = join( "\n", @sample_lines );
}
}
# NOTE: string
if( $type eq 'string' || $type eq 'scalar' )
{
$code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" );
# If this is an inheriting object class and this method exists in our parent class, no need to produce it, but we do create the POD documentation for clarity and simplicity of browsing for the end user.
if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) )
{
$lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" );
}
else
{
$lines->push( "sub $meth { return( shift->_set_get_scalar_as_object( '$meth', \@_ ) ); }\n" );
}
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$string = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets a string and returns a scalar object, even if there is no value. EOT $synop->push( "my \$string = \$obj->${meth};" ); $test_content .= <<EOT; is( \$obj->${meth}, \$test_data->{$meth}, '${meth}' ); EOT } # NOTE: array or array_as_object elsif( $type eq 'array' || $type eq 'array_as_object' ) { $code .= sprintf( " \$self->%-*s = [] unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_array_as_object( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$array = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets an array of ${prop_term_plural} and returns an array object, even if there is no value. EOT $synop->push( "my \$array = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; ok( ( Scalar::Util::reftype( \$this ) eq 'ARRAY' && Scalar::Util::blessed( \$this ) ), '${meth} returns an array object' ); if( defined( \$test_data->\{${meth}\} ) ) { ok( scalar( \@\$this ) == scalar( \@{\$test_data->\{${meth}\}} ), '${meth} -> array size matches' ); for( my \$i = 0; \$i < \@\$this; \$i++ ) { is( \$this->\[\$i\], \$test_data->\{${meth}\}->\[\$i\], '${meth} -> value offset \$i' ); } } else { ok( !scalar( \@\$this ), '${meth} -> array is empty' ); } EOT } # NOTE: hash elsif( $type eq 'hash' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_hash_as_mix_object( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$hash_obj = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets an hash reference of ${prop_term_plural} and returns an hash object. If no value is set, it will return an empty hash object in object context, or undef in scalar context, or an empty list in list context. EOT $synop->push( "my \$hash_obj = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; if( defined( \$test_data->\{${meth}\} ) ) { isa_ok( \$this => 'Module::Generic::Hash', '${meth}' ); } else { is( \$this => \$test_data->\{${meth}\}, '${meth}' ); } EOT } # NOTE: version elsif( $type eq 'version' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( exists( $sample_data->{ $meth } ) ) { $example = <<EOT; \$obj->${meth}\( $sample_data_string \); my \$version = \$obj->${meth};
EOT }
if( exists( $def->{def} ) && ref( $def->{def} ) eq 'HASH' )
{
my $dict_as_string = Data::Pretty::dump( $def->{def} );
if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) )
{
$lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" );
}
else
{
$lines->push( "sub $meth { return( shift->_set_get_version( $dict_as_string, \@_ ) ); }\n" );
}
my $version_class = ( $def->{def}->{class} // $def->{def}->{package} ) || die( "No class or package set for version in method $meth for object $object -> ${dict_as_string}\n" );
$pod->push( <<EOT );
=head2 $meth${example}Sets or gets a version value and returns a version object using ${version_class}. EOT } else { if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_version( '$meth', \@_ ) ); }\n" ); }
$pod->push( <<EOT );
=head2 $methSets or gets a version value and returns a version object using version. EOT } $synop->push( "my \$vers = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; is( \$this, \$test_data->\{${meth}\}, '${meth}' ); EOT } # NOTE: class_array_object or class elsif( $type eq 'class_array_object' || $type eq 'class' ) { my $sample = $sample_data->{ $meth }; foreach my $k ( keys( %{$def->{def}} ) ) { if( $def->{def}->{ $k } eq 'string' || $def->{def}->{ $k } eq 'scalar' ) { $def->{def}->{ $k } = 'scalar_as_object'; } elsif( $def->{def}->{ $k } eq 'array' ) { $def->{def}->{ $k } = 'array_as_object'; } elsif( $def->{def}->{ $k } eq 'hash' ) { $def->{def}->{ $k } = 'hash_as_object'; } }
if( $type eq 'class_array_object' )
{
$code .= sprintf( " \$self->%-*s = \[\] unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" );
$synop->push( "my \$array = \$obj->${meth};" );
$synop->push( "foreach my \$this ( \@\$array )" );
$synop->push( "{" );
foreach my $k ( sort( keys( %{$def->{def}} ) ) )
{
my $type = [split( /_/, $def->{def}->{ $k } )]->[0];
$synop->push( " my \$${type} = \$this->${k};" );
}
$synop->push( "}" );
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$array = \$obj->${meth};
foreach my \$this ( \@\$array )
{
EOT
foreach my $k ( sort( keys( %{$def->{def}} ) ) )
{
my $type = [split( /_/, $def->{def}->{ $k } )]->[0];
if( defined( $sample->[0]->{ $k } ) && length( $sample->[0]->{ $k } ) )
{
my $sample_str = Data::Dump::dump( $sample->[0]->{ $k } );
$example .= " \$this->${k}( ${sample_str} );\n";
}
$example .= " my \$${type} = \$this->${k};\n";
}
$example .= <<EOT;
}EOT } } # $type eq 'class' else { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); $synop->push( "my \$this = \$obj->${meth};" ); foreach my $k ( sort( keys( %{$def->{def}} ) ) ) { my $type; if( ref( $def->{def}->{ $k } ) eq 'HASH' ) { $type = "${k}_obj"; } else { $type = [split( /_/, $def->{def}->{ $k } )]->[0]; } $synop->push( "my \$${type} = \$obj->${meth}->${k};" ); } if( exists( $sample_data->{ $meth } ) ) { $example = <<EOT; \$obj->${meth}\( $sample_data_string \); my \$this = \$obj->${meth}; EOT foreach my $k ( sort( keys( %{$def->{def}} ) ) ) { my $type; if( ref( $def->{def}->{ $k } ) eq 'HASH' ) { $type = "${k}_obj"; } else { $type = [split( /_/, $def->{def}->{ $k } )]->[0]; } if( defined( $sample->{ $k } ) && length( $sample->{ $k } ) ) { # my $sample_str = Data::Dump::dump( $sample->{ $k } ); my $sample_str = &dump_this( $sample->{ $k } ); # $sample_data_string = Data::Dumper::Concise::Dumper( $sample_data->{ $meth } ); # $sample_data_string =~ s/\n$//gs; if( index( $sample_str, "\n" ) != -1 ) { my @sample_lines = split( /\n/, $sample_str ); # We start from 1 on purpose for( my $i = 1; $i < scalar( @sample_lines ); $i++ ) { substr( $sample_lines[$i], 0, 0, ' ' ); } $sample_str = join( "\n", @sample_lines ); } $example .= " \$obj->${meth}->${k}( ${sample_str} );\n"; } $example .= " my \$${type} = \$obj->${meth}->${k};\n"; } $example .= <<EOT;
EOT } } die( "No method definition is provided for method $meth in object $object\n" ) if( !exists( $def->{def} ) || ref( $def->{def} ) ne 'HASH' ); my $method_class = $meth; $method_class =~ tr/-/_/; $method_class =~ s/\_{2,}/_/g; $method_class = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $method_class ) ) );
my $dict_as_string = Data::Pretty::dump( $def->{def} );
if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) )
{
$lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" );
}
else
{
$lines->push( "sub $meth { return( shift->_set_get_${type}( '$meth', $dict_as_string, \@_ ) ); }\n" );
}
my $props_definition = &definition_to_pod( $def->{def} );
my $this_prop_pod;
if( $type eq 'class_array_object' )
{
$this_prop_pod = <<EOT;
=head2 $meth${example}Sets or gets an array of dynamic class objects with class name ${module_class}::${method_class} and having the folowing properties also accessible as methods, and returns an array object even if there is no value.
A ${module_class}::${method_class} object will be instantiated with each value from the array provided and replace said value.
${props_definition} EOT $test_content .= <<EOT; \$this = \$obj->${meth}; isa_ok( \$this => 'Module::Generic::Array', '${meth} returns an array object' ); EOT } # $type eq 'class' else { $this_prop_pod = <<EOT; =head2 $meth
${example}Sets or gets a dynamic class object with class name ${module_class}::${method_class} and having the folowing properties also accessible as methods, and returns an object from such class, or undef if no value was provided.
${props_definition} EOT $test_content .= <<EOT; \$this = \$obj->${meth}; ok( Scalar::Util::blessed( \$this ), '${meth} returns a dynamic class' ); EOT } $this_prop_pod =~ s/\n$//gs; $pod->push( "$this_prop_pod\n" ); } # NOTE: scalar_or_object elsif( $type eq 'scalar_or_object' ) { $code .= sprintf( " \$self->%-*s = \[\] unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); my $class = $def->{class} || $def->{package} || die( "No ckass or package was specified for the method $meth in object $object\n" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_scalar_or_object( '$meth', '$class', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
# Returns a scalar object when this is a string, or an ${class} object
my \$${meth} = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets either a string or an ${class} object, and returns either a scalar object or an ${class} object, or undef if nothing was set. EOT $synop->push( "# Returns a scalar object when this is a string, or an ${class} object" ); $synop->push( "my \$${meth} = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; if( defined( \$this ) ) { if( ref( \$this ) ) { isa_ok( \$this => '$class', '${meth} returns a ${class} object' ); } else { is( \$this => \$test_data->\{${meth}\}, '${meth} returns a string' ); } } EOT } # NOTE: object_array_object elsif( $type eq 'object_array_object' ) { $code .= sprintf( " \$self->%-*s = \[\] unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); my $class = $def->{class} || $def->{package} || die( "No ckass or package was specified for the method $meth in object $object\n" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } elsif( exists( $def->{callback} ) ) { my $callback = $def->{callback}; $callback =~ s/\n$//gs; $lines->push( "sub $meth { return( shift->_set_get_object_array_object( { field => '$meth', callback => sub { ${callback} } }, '$class', \@_ ) ); }\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_object_array_object( '$meth', '$class', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$array = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets an array of ${class} objects, or creates an ${class} instance for each ${meth} provided in the array, and returns an array object, even if no value was provided. EOT $synop->push( "my \$array = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; isa_ok( \$this => 'Module::Generic::Array', '${meth} returns an array object' ); EOT } # NOTE: uri elsif( $type eq 'uri' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_uri( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$uri = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets an URI, and returns an URI object or undef if no value is set. EOT $synop->push( "my \$uri = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; is( \$this => \$test_data->\{${meth}\}, '${meth}' ); if( defined( \$test_data->\{${meth}\} ) ) { isa_ok( \$this => 'URI', '${meth} returns an URI object' ); } EOT } # NOTE: boolean elsif( $type eq 'boolean' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_boolean( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$sample_data_string = ( $sample_data->{ $meth } ? 1 : 0 );
$example = <<EOT;
\$obj->${meth}\(${sample_data_string}\);
my \$bool = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets a boolean value, and returns a boolean object or undef if no value is set. EOT $synop->push( "my \$bool = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; if( defined( \$test_data->\{${meth}\} ) ) { is( \$this => \$test_data->\{${meth}\}, '${meth} returns a boolean value' ); } else { ok( !\$this, '${meth} returns a boolean value' ); } EOT } # NOTE: date or datetime elsif( $type eq 'date' || $type eq 'datetime' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_datetime( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\( $sample_data_string \);
my \$datetime_obj = \$obj->${meth};EOT } $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets a datetime value, and returns a DateTime object that stringifies to the format that was provided with the string set (usally an ISO 8601 datetime format) or undef if no value is set. EOT $synop->push( "my \$date = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; is( \$this => \$test_data->\{${meth}\}, '${meth}' ); if( defined( \$test_data->\{${meth}\} ) ) { isa_ok( \$this => 'DateTime', '${meth} returns a DateTime object' ); } EOT } # NOTE: integer or number or float or decimal elsif( $type eq 'integer' || $type eq 'number' || $type eq 'float' || $type eq 'decimal' ) { $code .= sprintf( " \$self->%-*s = ${default} unless( CORE::exists( \$self->\{${meth}\} ) );\n", $max, "\{${meth}\}" ); if( defined( $parent_specs ) && exists( $parent_specs->{ $meth } ) ) { $lines->push( "# NOTE: sub $meth is inherited from ${parent}\n" ); } elsif( exists( $def->{def} ) && ref( $def->{def} ) eq 'HASH' ) { my $field_def = { %{$def->{def}} }; $field_def->{field} = $meth; my $field_def_str = Data::Pretty::dump( $field_def ); $lines->push( "sub $meth { return( shift->_set_get_number( $field_def_str, \@_ ) ); }\n" ); } else { $lines->push( "sub $meth { return( shift->_set_get_number( '$meth', \@_ ) ); }\n" ); }
if( exists( $sample_data->{ $meth } ) )
{
$example = <<EOT;
\$obj->${meth}\($sample_data_string\);
my \$number = \$obj->${meth};EOT } my $pronoun = ( $type =~ /^(a|e|i|u|o)/ ? 'an' : 'a' ); $pod->push( <<EOT ); =head2 $meth
${example}Sets or gets ${pronoun} $type value, and returns a number object or undef if no value is set. EOT $synop->push( "my \$num = \$obj->${meth};" ); $test_content .= <<EOT; \$this = \$obj->${meth}; is( \$this => \$test_data->\{${meth}\}, '${meth}' ); if( defined( \$test_data->\{${meth}\} ) ) { isa_ok( \$this => 'Module::Generic::Number', '${meth} returns a number object' ); } EOT } else { die( "Unknown type '$type' for method '$meth' in object '$object'\n" ); }
# Do we have POD addendum ?
if( exists( $pod_more->{ $object }->{ $meth } ) &&
defined( $pod_more->{ $object }->{ $meth } ) &&
length( $pod_more->{ $object }->{ $meth } ) )
{
$pod->push( $pod_more->{ $object }->{ $meth } );
}
}
# NOTE: special methods treatment
if( exists( $special_methods->{ $object }->{_init_preprocess} ) )
{
$code .= " \$self->{_init_preprocess} = " . $special_methods->{ $object }->{_init_preprocess};
}
$code .= <<EOT;
\$self->{_init_strict_use_sub} = 1;
\$self->{_exception_class} = '${base_class}::Exception';
\$self->SUPER::init( \@_ ) || return( \$self->pass_error );
EOT
my $prefix = ' $self->{fields} = ';
my $fields_string = $prefix . '[qw( ' . join( ' ', @$methods_list ) . ' )];';
if( length( $fields_string ) > 80 )
{
$code .= "${prefix}\[qw\(\n";
my $fields_list = '';
my $tmpstr = ' ' x 8;
foreach my $f ( @$methods_list )
{
if( length( $tmpstr . " $f" ) > 90 )
{
$fields_list .= $tmpstr . "\n";
$tmpstr = ( ' ' x 8 ) . $f;
}
else
{
$tmpstr .= ( $tmpstr =~ /^[[:blank:]]*$/ ? $f : " ${f}" );
}
}
$fields_list .= $tmpstr if( length( $tmpstr ) );
$code .= $fields_list;
# $code .= "\n" . ( ' ' x length( $fields_string ) ) . ")];\n";
$code .= "\n" . ( ' ' x 4 ) . ")];\n";
}
else
{
$code .= $fields_string . "\n";
}
$code .= <<EOT;
return( \$self );
}EOT $code .= $lines->join( "\n" )->scalar; my $pod_lines = $pod->join( "\n" )->scalar; $synop = $synop->join( "\n" )->split( qr/\n/ ); foreach( @$synop ) { substr( $_, 0, 0, ' ' ); } my $synop_lines = $synop->join( "\n" )->scalar; my $module_short_description = exists( $pod_more->{ $object }->{__description} ) ? $pod_more->{ $object }->{__description} : "This class serves to retrieve and manipulate ${object_plural}."; $module_short_description =~ s/\n$//gs; $code .= <<EOT;
1; # NOTE: POD __END__
NAME
${module_class} - Meta CPAN API ${module_name} Class
SYNOPSIS
use ${module_class};
${synop_lines}VERSION
${module_version}DESCRIPTION
${module_short_description}
It inherits from ${base_class}::Generic
CONSTRUCTOR
new
Provided with an hash or hash reference of parameters, and this instantiates a new ${module_class} object.
The parameters that can be provided bear the same name and supports the same values as the methods below.
METHODS
${pod_lines} EOT
my $test_object_data;
if( $sample_file->exists )
{
# Add 4 spaces to show it as code in POD
my $sample_lines = $sample_file->load_utf8->split( qr/\n/ );
# Make a copy before modifications
$test_object_data = [@$sample_lines];
# my $sample_lines = $sample_file->content( binmode => 'utf8' );
for( @$sample_lines )
{
substr( $_, 0, 0, ' ' );
}
local $" = "\n";
$code .= <<EOT;
=head1 API SAMPLE@$sample_lines
EOT } else { $test_object_data = ["{}"]; }
$code .= <<EOT;
=head1 AUTHORJacques Deguest <jack\@deguest.jp>
SEE ALSO
${base_class}, ${base_class}::Activity, ${base_class}::Author, ${base_class}::Changes, ${base_class}::Changes::Release, ${base_class}::Contributor, ${base_class}::Cover, ${base_class}::Diff, ${base_class}::Distribution, ${base_class}::DownloadUrl, ${base_class}::Favorite, ${base_class}::File, ${base_class}::Module, ${base_class}::Package, ${base_class}::Permission, ${base_class}::Rating, ${base_class}::Release
MetaCPAN::API, MetaCPAN::Client
https://github.com/metacpan/metacpan-api/blob/master/docs/API-docs.md
COPYRIGHT & LICENSE
Copyright(c) ${year} DEGUEST Pte. Ltd.
All rights reserved
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.