File Coverage

gen/attr-PerlBean.pl

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

use strict;

use PerlBean::Style qw(:codegen);
my $pkg = 'PerlBean';

push(@::bean_desc, {
    bean_opt => {
        abstract => 'Code generation for bean like Perl modules',
        package => $pkg,
        use_perl_version => 5.005,
        short_description => 'Package to generate bean like Perl modules',
        synopsis => &get_syn(),
        description => <
The C<$pkg> class models a Perl module with one package. After adding different components to the C<$pkg>, the Perl module can be generated.

The following sections in the code generated by a C<$pkg> are used to explain the concept.

=over

=item C<$pkg> module file header section

 package Circle;

 use 5.008;
 use base qw( Shape Exporter );
 use strict;
 use warnings;
 use Error qw(:try);
 require Exporter;

=over

=item C

is used to set the package name in C.

=item C or C

are used to add C<${pkg}::Dependency> objects like the C and C lines in the example. Note however that except for C all C dependencies in the example above are set by default when initializing a C<$pkg> object without specifying a C option.

=item C

is used to set the version number in the C dependency. By default the version number is set to C<\\\$]>. This is an exception to the C<${pkg}::Dependency> mechanism.

=item C, C or C

are used to express inheritance relationships. When the C<$pkg> is written, the inheritance relationships -like C in this example- appear in the C list. The C bit is there because symbols are exported by C.

=back

=item C<$pkg> symbols:

=over

=item C or C

are used to add C<${pkg}::Symbol> objects. C<${pkg}::Symbol> objects are described in their own manual pages.

=back

=item C<$pkg> complimentary symbols:

 # Used by _value_is_allowed
 our \%ALLOW_ISA = (
 );

 # Used by _value_is_allowed
 our \%ALLOW_REF = (
 );

 # Used by _value_is_allowed
 our \%ALLOW_RX = (
     'radius' => [ '^\\d*(\\.\\d+)?\$' ],
 );

 # Used by _value_is_allowed
 our \%ALLOW_VALUE = (
 );

 # Used by _initialize
 our \%DEFAULT_VALUE = (
 );

 # Package version
 our (\$VERSION) = '\$Revision: 1.0 $' =~ /\\\$Revision:\\s+([^\\s]+)/;

The C symbols above are used by the generated class to check rules that apply to the C<$pkg>'s attributes. They are not exported. You could theoretically overwrite them. But don't do that!

The C symbol above is used at class instantiation to set the attribute's default values of the C. It is not exported. Sometimes you need to overwrite values. That's not particularly nice and should be addressed.

The C is there to allow versioning through CVS. You could overwrite it.

=item Preloaded section end

 1;

 __END__

If the C<$pkg> is C then the code above is generated in order to autoload the methods that follow. The method C is used to change the autoload behavior of a C<$pkg>. NOTE: In my experience it pays to first have C<$pkg>s preloaded and to switch to autoload after debugging.

=item NAME section

 =head1 NAME

 Circle - circle shape

The package name ( which was set through C ) is put in C.

=over

=item C

is used to set a short package description in C<- circle shape>.

=back

=item ABSTRACT section

 =head1 ABSTRACT

 circle shape

=over

=item C

is used to set the abstract information in C.

=back

=item DESCRIPTION section

 =head1 DESCRIPTION

 circle shape

=over

=item C

is used to set the description information C. If no description is set then CCircleE TODO> would be shown.

=back

=item EXPORT section

This section describes all exported C<${pkg}::Symbol> objects like in the following example.

 =head1 EXPORT

 By default nothing is exported.

 =head2 geo

 Geometric constants

 =over

 =item \$PI

 The PI constant

 =back

=item CONSTRUCTOR section

All constructors are documented in alphabetical order in this section. C<$pkg> by default generates documentation for the C constructor. In theory you can overwrite the C constructor and hence alter the documentation thereof. Before you do so, I suggest you thoroughly contemplate this. You can of course add a C<${pkg}::Method::Constructor> object ( e.g. C ) in order to customize construction.

=item METHODS section

All methods that aren't constructors are documented in alphabetical order in this section. C<${pkg}::Method> objects in the C by default generate documentation for the methods. In theory you can overwrite the methods. Again, I suggest you thoroughly contemplate the consequences.

=item SEE ALSO section

 L,
 L,
 L

All C<$pkg> objects inside a C<${pkg}::Collection> are referred in this section as listed.

=item BUGS section

 None known (yet.)

This section always has C in it.

=item HISTORY section

 First development: September 2003
 Last update: September 2003

This section always has Ccurrent_dateE Last update: CEcurrent_dateE> in it.

=item AUTHOR section

 Vincenzo Zocca

This section always has the B field from the C file.

=item COPYRIGHT section

 Copyright 2003 by Vincenzo Zocca

This section always contains the above message with the C and the B field from the C file.

=item LICENSE section

 This code is licensed under B.
 Details on L.

This section either contains:

1) The license of the C<$pkg> which set through method C

2) The license of the C<${pkg}::Collection>

3) The text C

=item Implementation section

This section contains the implementation of the methods and constructors. First listed are the constructors which are ordered alphabetically and C and C<_initialize()> are kept near to each-other. Then the normal methods are listed alphabetically.

=item End of file

 1;

If the C<$pkg> is not C then the code above is generated in order to close the file the I way. The method C is used to change the autoload behavior of a C<$pkg>. NOTE: In my experience it pays to first have C<$pkg>s preloaded and to switch to autoload after debugging.

=back
EOF
    },
    attr_opt => [
        {
            method_factory_name => 'abstract',
            type => 'SINGLE',
            allow_rx => [qw(^.*$)],
            short_description => 'the PerlBean\'s abstract (a one line description of the module)',
        },
        {
            method_factory_name => 'method_factory',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            method_key => 1,
            id_method => 'get_method_factory_name',
            short_description => 'the list of \'PerlBean::Method::Factory\' objects',
            allow_isa => [ qw( PerlBean::Method::Factory ) ],
        },
        {
            method_factory_name => 'base',
            type => 'MULTI',
            unique => 1,
            ordered => 1,
            short_description => 'the list of class names in use base',
            allow_rx => [qw(^\S+$)],
        },
        {
            method_factory_name => 'collection',
            allow_isa => [qw(PerlBean::Collection)],
            short_description => 'class to throw when exception occurs',
        },
        {
            method_factory_name => 'description',
            short_description => 'the PerlBean description',
        },
        {
            method_factory_name => 'exception_class',
            allow_empty => 0,
            default_value => 'Error::Simple',
            short_description => 'class to throw when exception occurs',
        },
        {
            method_factory_name => 'autoloaded',
            type => 'BOOLEAN',
            short_description => 'the methods in the PerlBean are autoloaded',
            default_value => 1,
        },
        {
            method_factory_name => 'dependency',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            method_key => 1,
            id_method => 'get_dependency_name',
            short_description => 'the list of \'PerlBean::Dependency\' objects',
            allow_isa => [ qw( PerlBean::Dependency ) ],
            default_value => [ 'XXXX' ],
        },
        {
            method_factory_name => 'export_tag_description',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            method_key => 1,
            id_method => 'get_export_tag_name',
            short_description => 'the list of \'PerlBean::Described::ExportTag\' objects',
            allow_isa => [ qw( PerlBean::Described::ExportTag ) ],
        },
        {
            method_factory_name => 'singleton',
            type => 'BOOLEAN',
            short_description => 'the package is a singleton and an C method is implemented',
            default_value => 0,
        },
        {
            method_factory_name => 'license',
            type => 'SINGLE',
            allow_rx => [qw(.*)],
            short_description => 'the software license for the PerlBean',
        },
        {
            method_factory_name => 'symbol',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            method_key => 1,
            id_method => 'get_symbol_name',
            short_description => 'the list of \'PerlBean::Symbol\' objects',
            allow_isa => [qw(PerlBean::Symbol)],
        },
        {
            method_factory_name => 'method',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            method_key => 1,
            id_method => 'get_method_name',
            short_description => 'the list of \'PerlBean::Method\' objects',
            allow_isa => [qw(PerlBean::Method)],
        },
        {
            method_factory_name => 'package',
            allow_empty => 0,
            mandatory => 1,
            short_description => 'package name',
        },
        {
            method_factory_name => 'use_perl_version',
            allow_empty => 0,
            default_value => '$]',
            allow_rx => [ qw( ^v?\d+\(\.[\d_]+\)* ) ],
            short_description => 'the Perl version to use',
        },
        {
            method_factory_name => 'short_description',
            short_description => 'the short PerlBean description',
            default_value => 'NO DESCRIPTION AVAILABLE',
        },
        {
            method_factory_name => 'synopsis',
            type => 'SINGLE',
            allow_rx => [qw(.*)],
            short_description => 'the synopsis for the PerlBean',
        },
        {
            method_factory_name => '_finalized_',
            type => 'BOOLEAN',
            documented => 0,
            default_value => 0,
        },
        {
            method_factory_name => '_has_exports_',
            type => 'BOOLEAN',
            documented => 0,
            default_value => 0,
        },
        {
            method_factory_name => '_export_tag_',
            type => 'MULTI',
            unique => 1,
            associative => 1,
            documented => 0,
            description => <
Internal list of all accumulated export tags of the PerlBean's symbols.
EOF
        },
    ],
    meth_opt => [
        {
            method_name => '_by_pragma',
            documented => 0,
            body => <
    if (\$a =~ /^[a-z]/ && \$b !~ /^[a-z]/ ) {
        return(-1);
    }
    elsif (\$a !~ /^[a-z]/ && \$b =~ /^[a-z]/ ) {
        return(1);
    }
    else {
        return(\$a cmp \$b );
    }
EOF
        },
        {
            method_name => '_get_overloaded_attribute',
            documented => 0,
            parameter_description => 'MATCH_ATTRIBUTE, LOOP_STOP',
            description => <<'EOF',
Searches the superclass PerlBeans for an identically named attribute. C is the C object that must be matched in the search. C is used to detect loops in the inheritance. Returns a C if the search was successful and C otherwise.
EOF
            body => <<'THE_EOF',
    my $self = shift;
    my $match_attr = shift;
    my $loop_stop = shift;

    # Check for a loop
    my $pkg = $self->get_package();
    exists( $loop_stop->{$pkg} ) && throw Error::Simple("ERROR: PerlBean::_get_overloaded_attribute, loop detected in inheritance at bean '$pkg'.");
    $loop_stop->{$pkg} = 1;

    # Check and return attribute if found in this bean
    my $found_attr = ( $self->values_method_factory( $match_attr->get_method_factory_name() ) )[0];
    if ( defined($found_attr) ) {
        # Get the reference type of the attribute to match
        my $match_attr_ref = ref($match_attr);

        # Get the reference type of the found attribute
        my $found_attr_ref = ref($found_attr);

        # Match found if the reference types of the attribute to match and the found attribute are identical.
        ( $match_attr_ref eq $found_attr_ref ) && return($found_attr);

        # The reference types of the attribute to match and the found attribute are different. Throw a usable exception.
        my $name = $found_attr->get_method_factory_name();
        my $match_attr_pkg = $match_attr->get_perl_bean()->get_package();
        throw Error::Simple("ERROR: PerlBean::_get_overloaded_attribute, found an attribute named '$name' in package '$pkg' but the reference type '$found_attr_ref' was not as in package '$match_attr_pkg' ($match_attr_ref).");
    }

    # Check super classes
    foreach my $super_pkg ($self->get_base()) {
        # Get the super class bean
        my $super_bean = ( $self->get_collection()->values_perl_bean($super_pkg) )[0];

        # If the super class bean has no bean in the collection then no attribute is found
        defined($super_bean) || return(undef);

        # See if the super class bean has an attribute
        my $attr_over = $super_bean->_get_overloaded_attribute( $match_attr, $loop_stop );

        # Return the overloaded bean if found
        defined($attr_over) && return($attr_over);
    }

    # Nothing found
    return(undef);
THE_EOF
        },
        {
            method_name => '_get_super_method',
            documented => 0,
            parameter_description => 'MATCH_METHOD, LOOP_STOP',
            description => <<'EOF',
Searches the superclass PerlBeans for an identically named method. C is the C object that must be matched in the search. C is used to detect loops in the inheritance. Returns a C if the search was successful and C otherwise.
EOF
            body => <<'THE_EOF',
    my $self = shift;
    my $match_meth = shift;
    my $loop_stop = shift;

    # Check for a loop
    my $pkg = $self->get_package();
    exists( $loop_stop->{$pkg} ) && throw Error::Simple("ERROR: PerlBean::_get_super_method, loop detected in inheritance at bean '$pkg'.");
    $loop_stop->{$pkg} = 1;

    # Check and return method if found in this bean
    my $found_meth = ( $self->values_method( $match_meth->get_method_name() ) )[0];
    defined($found_meth) && return($found_meth);

    # Check super classes
    foreach my $super_pkg ($self->get_base()) {
        # Get the super class bean
        my $super_bean = ( $self->get_collection()->values_perl_bean($super_pkg) )[0];

        # If the super class bean has no bean in the collection then no method is found
        defined($super_bean) || return(undef);

        # See if the super class bean has the method
        my $found_meth = $super_bean->_get_super_method( $match_meth, $loop_stop );

        # Return the overloaded bean if found
        defined($found_meth) && return($found_meth);
    }

    # Nothing found
    return(undef);
THE_EOF
        },
        {
            method_name => '_get_effective_attributes',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $done = shift;
    my $loop_stop = shift || {};

    # Check for a loop
    my $pkg = $self->get_package();
    exists( $loop_stop->{$pkg} ) && throw Error::Simple("ERROR: PerlBean::_get_effective_attributes, loop detected for bean '$pkg'.");
    $loop_stop->{$pkg} = 1;

    # Add own attributes
    foreach my $method_factory ( $self->values_method_factory() ) {
        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        # Only do not done
        exists( $done->{ $method_factory->get_method_factory_name() } ) && next;

        # Remember the attribute by name
        $done->{ $method_factory->get_method_factory_name() } = $method_factory;
    }

    # Add attributes from super classes
    foreach my $super_pkg ($self->get_base()) {
        # Get the super class bean
        my $super_bean = ($self->get_collection()->values_perl_bean($super_pkg))[0];

        # If the super package is not in the collection, well too bad (for now anyway)
        defined($super_bean) || next;

        # See if the super class bean has an attribute
        $super_bean->_get_effective_attributes( $done, $loop_stop );
    }
THE_EOF
        },
        {
            method_name => '_get_effective_methods',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $eff_meth = shift;
    my $loop_stop = shift || {};

    # Check for a loop
    my $pkg = $self->get_package();
    exists( $loop_stop->{$pkg} ) && throw Error::Simple("ERROR: PerlBean::_get_effective_methods, loop detected for bean '$pkg'.");
    $loop_stop->{$pkg} = 1;

    # Add own methods
    foreach my $meth ( $self->values_method() ) {
        exists( $eff_meth->{ $meth->get_method_name() } ) && next;
        $eff_meth->{ $meth->get_method_name() } = $meth;
    }

    # End if collection not set
    defined( $self->get_collection() ) || return;

    # Add methods from super classes
    foreach my $super_pkg ( $self->get_base() ) {
        # Get the super class bean
        my $super_bean = ( $self->get_collection()->values_perl_bean($super_pkg) )[0];

        # If the super package is not in the collection, well too bad (for now anyway)
        defined($super_bean) || next;

        # See if the super class bean has an attribute
        $super_bean->_get_effective_methods( $eff_meth, $loop_stop );
    }
THE_EOF
        },
        {
            method_name => '_finalize',
            documented => 0,
            description => <<'EOF',
Finalize the object by:
1) removing volatile methods and symbol
2) checking for exports
3) making the singleton symbol and method
4) making autoload thingies,
5) making 'use base' for inheritance
6) exporting symbols
7) making the $VERSION symbol
8) adding methods from the attribute factories
9) calling set__finalized_(1)
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove all volatile dependencies
    $self->_rm_volatile_dependencies();

    # Remove all volatile methods
    $self->_rm_volatile_methods();

    # Remove all volatile symbols
    $self->_rm_volatile_symbols();

    # Check if exporter is needed
    $self->_mk__has_exports_();

    # Finalize constructor
    $self->_finalize_constructor();

    # Finalize singleton
    $self->_finalize_singleton();

    # Finalize autoload
    $self->_finalize_autoload();

    # Finalize allowed
    $self->_finalize_allowed();

    # Finalize default values
    $self->_finalize_default();

    # Finalize 'use base'
    $self->_finalize_use_base();

    # Finalize exports
    $self->_finalize_exports();

    # Finalize version
    $self->_finalize_version();

    # Finalize method factories
    $self->_finalize_method_factories();

    # Remember this object is finalized
    $self->set__finalized_(1);
EOF
        },
        {
            method_name => '_finalize_allowed',
            documented => 0,
            description => <<'EOF',
Finalized the allowed thingies by:
1) checking if constraints apply
2) deleting constraint symbols if no constraints
3) adding the constraint symbols if constraints apply
4) adding the _value_is_allowed() method
EOF
            body => <<'EOF',
    my $self = shift;

    # Check for constraints
    my $constraints = 0;
    my $has_attributes = 0;
    foreach my $method_factory ( $self->values_method_factory() ) {
        # Only check attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        # Remember we actually found attributes
        $has_attributes = 1;

        # Check for constraints
        $constraints =
            $method_factory->write_allow_isa() ||
            $method_factory->write_allow_ref() ||
            $method_factory->write_allow_rx() ||
            $method_factory->write_allow_value();
        $constraints && last;
    }

    # Make _value_allowed
    $self->_mk_value_allowed_method($constraints, $has_attributes);

    # Delete the allow symbols if no constraints
    $constraints ||
        $self->delete_symbol( qw( %ALLOW_ISA %ALLOW_REF
                                        %ALLOW_RX %ALLOW_VALUE ) );

    # Return if no constraints
    $constraints || return();

    # %ALLOW_ISA symbol
    my $assignment = "(\n";
    foreach my $name ( sort( $self->keys_method_factory() ) ) {
        # Make method factory out of name
        my $method_factory = ( $self->values_method_factory($name) )[0];

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        $assignment .= $method_factory->write_allow_isa();
    }
    $assignment .= ");\n";
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '%ALLOW_ISA',
        assignment => $assignment,
        comment => "# Used by _value_is_allowed\n",
        volatile => 1,
    } ) );

    # %ALLOW_REF symbol
    $assignment = "(\n";
    foreach my $name ( sort( $self->keys_method_factory() ) ) {
        # Make method factory out of name
        my $method_factory = ( $self->values_method_factory($name) )[0];

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        $assignment .= $method_factory->write_allow_ref();
    }
    $assignment .= ");\n";
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '%ALLOW_REF',
        assignment => $assignment,
        comment => "# Used by _value_is_allowed\n",
        volatile => 1,
    } ) );

    # %ALLOW_RX symbol
    $assignment = "(\n";
    foreach my $name ( sort( $self->keys_method_factory() ) ) {
        # Make method factory out of name
        my $method_factory = ( $self->values_method_factory($name) )[0];

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        $assignment .= $method_factory->write_allow_rx();
    }
    $assignment .= ");\n";
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '%ALLOW_RX',
        assignment => $assignment,
        comment => "# Used by _value_is_allowed\n",
        volatile => 1,
    } ) );

    # %ALLOW_VALUE symbol
    $assignment = "(\n";
    foreach my $name ( sort( $self->keys_method_factory() ) ) {
        # Make method factory out of name
        my $method_factory = ( $self->values_method_factory($name) )[0];

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        $assignment .= $method_factory->write_allow_value();
    }
    $assignment .= ");\n";
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '%ALLOW_VALUE',
        assignment => $assignment,
        comment => "# Used by _value_is_allowed\n",
        volatile => 1,
    } ) );
EOF
        },
        {
            method_name => '_finalize_constructor',
            documented => 0,
            description => <<'EOF',
Create constructor methods and doc
EOF
            body => <<'EOF',
    my $self = shift;

    # Do nothing if new() and _initialize() exist already.
    ! $self->exists_method('new') ||
        ! $self->exists_method('_initialize') ||
            return;

    # The own attributes
    my %own_attr = ();
    foreach my $method_factory ( $self->values_method_factory() ) {

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        # Remember the attribute by name
        $own_attr{ $method_factory->get_method_factory_name() } =
            $method_factory;
    }

    # Get the effective attributes for this bean, remember if one or more
    # attributes are mandatory and remember all package names
    $self->_get_effective_attributes( \my %eff_attr );
    my $mand = 0;
    my %eff_pkg = ();
    foreach my $attr ( values(%eff_attr) ) {
        # Is the attribute mandatory?
        $mand ||= $attr->is_mandatory();

        # Remember the package name
        $eff_pkg{ $attr->get_package() }{ $attr->get_method_factory_name() } =
            $attr;
    }

    # Make if new() method if it doesn't already exists
    $self->exists_method('new') ||
        $self->_finalize_constructor_new( \%own_attr, \%eff_pkg, $mand );

    # Make if _initialize() method if it doesn't already exists
    $self->exists_method('_initialize') ||
        $self->_finalize_constructor_initialize( \%own_attr );
EOF
        },
        {
            method_name => '_finalize_constructor_initialize',
            documented => 0,
            description => <<'EOF',
Create _initialize() method if necessary
EOF
            body => <<'THE_EOF',
    my $self = shift;
    my $own_attr = shift;

    # Implement _initialize() only if:
    # 1) the PerlBean has own attributes
    # 2) the PerlBean is not derived
    # 3) the PerlBean has more than one superclass
    # 4) the one superclass of the PerlBean's is not in the collection
    # 1)
    my $do_implement = scalar( keys( %{$own_attr} ) );
    # 2)
    $do_implement ||= ! scalar( $self->get_base() );
    # 3)
    $do_implement ||= scalar( $self->get_base() ) > 1;
    # 4)
    if ( ! $do_implement &&
            defined( $self->get_collection() ) &&
                scalar( $self->get_base() ) ) {
        my $super_in_collection = 1;
        foreach my $base ( $self->get_base() ) {
            $super_in_collection &&= scalar( $self->get_collection()->
                                                    values_perl_bean($base) );
        }
        $do_implement = ! $super_in_collection;
    }
    $do_implement || return;

    my $pkg = $self->get_package();
    my $ec = $self->get_exception_class();

    my $body = <
${IND}my \$self${AO}=${AO}shift;
${IND}my \$opt${AO}=${AO}defined${BFP}(\$_[0])${AO}?${AO}shift${AO}:${AO}\{};

${IND}# Check \$opt
${IND}ref${BFP}(\$opt)${AO}eq${AO}'HASH'${AO}||${AO}throw $ec${BFP}("ERROR: ${pkg}::_initialize, first argument must be 'HASH' reference.");

EOF

    # Add code for own attributes
    foreach my $name ( sort( keys( %{$own_attr} ) ) ) {
        $body .= $own_attr->{$name}->write_constructor_option_code();
    }

    # superclass' _initialize
    if ( scalar ( $self->get_base() ) == 1 ) {
        $body .= <
${IND}# Call the superclass' _initialize
${IND}\$self->SUPER::_initialize${BFP}(\$opt);

EOF
    }
    elsif ( scalar ( $self->get_base() ) ) {
        $body .= <
${IND}# Call the superclass' _initialize
EOF
        foreach my $super ( $self->get_base() ) {
        $body .= <
${IND}\$self->${super}::_initialize${BFP}(\$opt);
EOF
        }
        $body .= "\n";
    }

    # Code to return $self
    $body .= <
${IND}# Return \$self
${IND}return${BFP}(\$self);
EOF

    # Make and add the method
    $self->add_method( PerlBean::Method->new( {
        method_name => '_initialize',
        documented => 0,
        volatile => 1,
        body => $body,
    } ) );
THE_EOF
        },
        {
            method_name => '_finalize_constructor_new',
            documented => 0,
            description => <<'EOF',
Create new() method if necessary
EOF
            body => <<'THE_EOF',
    my $self = shift;
    my $own_attr = shift;
    my $eff_pkg = shift;
    my $mand = shift;

    # Implement new() only if:
    # 1) the PerlBean is not derived
    # 2) not all the PerlBean's superclasses are in the collection
    my $do_implement = ! scalar( $self->get_base() );
    if ( ! $do_implement &&
            defined( $self->get_collection() ) &&
                scalar( $self->get_base() ) ) {
        my $super_in_collection = 1;
        foreach my $base ( $self->get_base() ) {
            $super_in_collection &&= scalar( $self->get_collection()->
                                                    values_perl_bean($base) );
        }
        $do_implement = ! $super_in_collection;
    }

    my $pkg = $self->get_package();
    my $ec = $self->get_exception_class();

    # Describe OPT_HASH_REF if the PerlBean has attributes or its superclasses
    # have.
    my $do_opt_hash_ref = scalar( keys( %{$eff_pkg} ) );

    # Start the description
    my $desc = "Creates a new C<$pkg> object.";
    $desc .= ! $do_opt_hash_ref ? '' :
        " C is a hash reference used to pass initialization options.";

    # If this PerlBean or its superclass PerlBeans have 'mandatory' attributes,
    # then the OPT_HASH_REF parameter is mandatory
    my $parameter_description = '';
    if (! $do_opt_hash_ref) {
        $desc .= "\n";
    }
    else {
        $parameter_description = "${ACS}\[${ACS}OPT_HASH_REF${ACS}\]${ACS}";
        if ($mand) {
            $desc .= ' C is mandatory.';
            $parameter_description = 'OPT_HASH_REF';
        }

        # Add exception message to the description
        $desc .= <
 On error an exception C<$ec> is thrown.
EOF

        # Add pod for own attributes
        if ( scalar( keys( %{$own_attr} ) ) ) {
            $desc .= <

Options for C may include:

\=over
EOF
            foreach my $name ( sort( keys( %{$own_attr} ) ) ) {
                $desc .= $own_attr->{$name}->write_constructor_option_doc();
            }

            # Close =over
            $desc .= <

\=back
EOF

        }

        # Add pod for inherited attributes
        foreach my $pkg_name ( sort( keys( %{$eff_pkg} ) ) ) {
            # Don't do own package
            $pkg_name eq $self->get_package() && next;

            $desc .= <

Options for C inherited through package B> may include:

\=over
EOF

            foreach my $attr_name ( sort( keys( %{$eff_pkg->{$pkg_name}} ) ) ) {
                $desc .= $eff_pkg->{$pkg_name}{$attr_name}->
                                                write_constructor_option_doc();
            }

            # Close =over
            $desc .= <

\=back
EOF
        }
    }

    # Make the body
    my $body = <
${IND}my \$class${AO}=${AO}shift;

${IND}my \$self${AO}=${AO}\{};
${IND}bless${BFP}(${ACS}\$self,${AC}(${ACS}ref${BFP}(\$class)${AO}||${AO}\$class${ACS})${ACS});
${IND}return${BFP}(${ACS}\$self->_initialize${BFP}(\@_)${ACS});
EOF

    # Make and add the method
    $self->add_method( PerlBean::Method::Constructor->new( {
        method_name => 'new',
        parameter_description => $parameter_description,
        volatile => 1,
        description => $desc,
        implemented => $do_implement,
        body => $body,
    } ) );
THE_EOF
        },
        {
            method_name => '_finalize_method_factories',
            documented => 0,
            description => <<'EOF',
Create methods from the method factories and add them to the object if not already in the method.
EOF
            body => <<'EOF',
    my $self = shift;

    # Add all methods from all method factories
    foreach my $method_factory ( $self->values_method_factory() ) {

        # Try adding each method from the factory
        foreach my $meth ( $method_factory->create_methods() ) {
            # Don't add the method if already present
            $self->exists_method( $meth->get_method_name() ) && next;

            # Add the method
            $self->add_method( $meth );
        }
    }
EOF
        },
        {
            method_name => '_finalize_autoload',
            documented => 0,
            description => <<'EOF',
Finalizes the AutoLoader thingies by:
1) removing the AutoLoader dependency if not autoloaded
2) adding the AutoLoader dependency if autoloaded and the dependency not
   already in object.
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove AutoLoader dependency if not autoloaded
    $self->is_autoloaded() || $self->delete_dependency('AutoLoader');

    # Return if not autoloaded
    $self->is_autoloaded() || return;

    # Return if AutoLoader dependency already exists
    $self->exists_dependency('AutoLoader') && return;

    # Add AutoLoader dependency
    $self->add_dependency( PerlBean::Dependency::Use->new( {
            dependency_name => 'AutoLoader',
            import_list => [ 'qw(AUTOLOAD)' ],
            volatile => 1,
    } ) );
EOF
        },
        {
            method_name => '_finalize_default',
            documented => 0,
            description => <<'EOF',
Finalizes the %DEFAULT_VALUE symbol by:
1) creating one if not already there
EOF
            body => <<'EOF',
    my $self = shift;

    # Don't add the '%DEFAULT_VALUE' if it exists already
    $self->exists_symbol( '%DEFAULT_VALUE' ) && return();

    # %DEFAULT_VALUE symbol
    my $has_default_value = '';
    my $assignment = "(\n";
    foreach my $name ( sort( $self->keys_method_factory() ) ) {
        # Make method factory out of name
        my $method_factory = ( $self->values_method_factory($name) )[0];

        # Only do attributes
        $method_factory->isa( 'PerlBean::Attribute' ) || next;

        $assignment .= $method_factory->write_default_value();
        $has_default_value ||= $method_factory->write_default_value();
    }
    $assignment .= ");\n";

    # Don't add the '%DEFAULT_VALUE' if there aren't any default values
    $has_default_value || return();

    # Add the symbol
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '%DEFAULT_VALUE',
        assignment => $assignment,
        comment => "# Used by _initialize\n",
        volatile => 1,
    } ) );
EOF
        },
        {
            method_name => '_finalize_exports',
            documented => 0,
            description => <<'EOF',
Finalizes the exporting by:
1) adding 'require Exporter' dependency if is__has_exports_()
2) deleting symbols %EXPORT_TAGS @EXPORT_OK @EXPORT if !is__has_exports_()
3) adding symbols %EXPORT_TAGS @EXPORT_OK @EXPORT if not already present
EOF
            body => <<'EOF',
    my $self = shift;

    # Delete the require Exporter dependency
    $self->delete_dependency('Exporter');

    # Delete %EXPORT_TAGS @EXPORT_OK @EXPORT if not exported
    $self->is__has_exports_() ||
        $self->delete_symbol( qw( %EXPORT_TAGS @EXPORT_OK @EXPORT ) );

    # That's it if no exports
    $self->is__has_exports_() || return;

    # require Exporter
    $self->add_dependency( PerlBean::Dependency::Require->new( {
        dependency_name => 'Exporter',
        volatile => 1,
    } ) );

    # Get all export tags
    $self->set__export_tag_();
    foreach my $sym ( $self->values_symbol() ) {
        foreach my $tag ( $sym->values_export_tag() ) {
            $self->exists__export_tag_($tag) ||
                                            $self->add__export_tag_($tag, []);
            push( @{ ( $self->values__export_tag_($tag) )[0] }, $sym );
        }
    }


    # Add %EXPORT_TAGS symbol if it doesn't already exist
    if ( ! $self->exists_symbol('%EXPORT_TAGS') ) {
        my $assignment = "(\n";
        foreach my $tag ( sort( $self->keys__export_tag_() ) ) {

            # The %EXPORT_TAGS assignment head for this tag
            $assignment .= "${IND}'$tag' => [ qw(\n";

            # Fill out the lines alphabetically
            foreach my $name ( sort( $self->keys_symbol() ) ) {

                 # Get the symbol
                 my $sym = ( $self->values_symbol($name) )[0];

                 # Skip if not in tag
                 $sym->exists_export_tag($tag) || next;

                 # Add the line
                 $assignment .= "${IND}${IND}$name\n";
            }

            # The %EXPORT_TAGS assignment tail for this tag
            $assignment .= "${IND}) ],\n";
        }

        # The %EXPORT_TAGS assignment tail
        $assignment .= ");\n";

        # Make and add the symbols %EXPORT_TAGS
        $self->add_symbol( PerlBean::Symbol->new( {
            symbol_name => '%EXPORT_TAGS',
            assignment => $assignment,
            comment => "# Exporter variable\n",
            volatile => 1,
        } ) );
    }


    # The @EXPORT_OK assignment head
    my $EOA = "qw(\n";

    # The @EXPORT assignment head
    my $EA = "qw(\n";

    # Fill $EOA and $EA
    foreach my $name ( sort( $self->keys_symbol() ) ) {
         # Get the symbol
         my $sym = ( $self->values_symbol($name) )[0];

         # Next if no tag
         $sym->values_export_tag() || next;

         # Add the line to $EOA
         $EOA .= "${IND}$name\n";

         # Next if no default tag
         $sym->exists_export_tag('default') || next;

         # Add the line to $EA
         $EA .= "${IND}$name\n";

    }

    # The @EXPORT_OK assignment tail
    $EOA .= ");\n";

    # The @EXPORT assignment tail
    $EA .= ");\n";

    # Add @EXPORT_OK symbol if it doesn't already exist
    ! $self->exists_symbol('@EXPORT_OK') &&
        $self->add_symbol( PerlBean::Symbol->new( {
            symbol_name => '@EXPORT_OK',
            assignment => $EOA,
            comment => "# Exporter variable\n",
            volatile => 1,
        } ) );

    # Add @EXPORT symbol if it doesn't already exist
    ! $self->exists_symbol('@EXPORT') &&
        $self->add_symbol( PerlBean::Symbol->new( {
            symbol_name => '@EXPORT',
            assignment => $EA,
            comment => "# Exporter variable\n",
            volatile => 1,
        } ) );
EOF
        },
        {
            method_name => '_finalize_singleton',
            documented => 0,
            description => <<'EOF',
Add a symbol $SINGLETON if it is not already in the object.
Add the method instance() if it is not already in the object.
EOF
            body => <<'THE_EOF',
    my $self = shift;

    $self->is_singleton() || return;

    # Make the $SINGLETON symbol if it doesn't exist already
    $self->exists_symbol('$SINGLETON') ||
        $self->add_symbol( PerlBean::Symbol->new( {
            symbol_name => '$SINGLETON',
            assignment => "undef;\n",
            comment => "# Singleton variable\n",
            volatile => 1,
        } ) );

    # Return if the instance() method already exists
    $self->exists_method('instance') && return();

    # Package name
    my $pkg = $self->get_package();

    # Make the instance() method
    $self->add_method( PerlBean::Method->new( {
        method_name => 'instance',
        parameter_description => ' [ CONSTR_OPT ] ',
        volatile => 1,
        description => <
Always returns the same C<${pkg}> -singleton- object instance. The first time it is called, parameters C -if specified- are passed to the constructor.
EOF
                body => <
${IND}# Allow calls like:
${IND}# - ${pkg}::instance()
${IND}# - ${pkg}->instance()
${IND}# - \$variable->instance()
${IND}if${BCP}(${ACS}ref${BFP}(\$_[0])${AO}&&${AO}&UNIVERSAL::isa(${ACS}\$_[0], '${pkg}'${ACS})${ACS}) {
${IND}${IND}shift;
${IND}}${PBCC[1]}elsif${BCP}(${ACS}!${AO}ref${BFP}(\$_[0])${AO}&&${AO}\$_[0]${AO}eq${AO}'${pkg}'${ACS})${PBOC[1]}{
${IND}${IND}shift;
${IND}}

${IND}# If \$SINGLETON is defined return it
${IND}defined${BFP}(\$SINGLETON) && return${BFP}(\$SINGLETON);

${IND}# Create the object and set \$SINGLETON
${IND}\$SINGLETON${AO}=${AO}${pkg}->new${BFP}();

${IND}# Initialize the object separately as the initialization might
${IND}# depend on \$SINGLETON being set.
${IND}\$SINGLETON->_initialize${BFP}(\@_);

${IND}# Return \$SINGLETON
${IND}return${BFP}(\$SINGLETON);
EOF
    } ) );
THE_EOF
        },
        {
            method_name => '_finalize_version',
            documented => 0,
            description => <<'EOF',
Add $VERSION if it does not already exists
EOF
            body => <<'EOF',
    my $self = shift;

    # Return if '$VERSION' or '($VERSION)' exists
    ( $self->exists_symbol('$VERSION') ||
                            $self->exists_symbol('($VERSION)') ) && return();

    # Make the $VERSION symbol
    my $va = '\'$';
    $va .= 'Revision: 0.0.0.0';
    $va .= " \$'${AO}=~${AO}/\\\$";
    $va .= 'Revision:\\s+([^\\s]+)/;';
    $va .= "\n";

    # Add the ($VERSION) symbol
    $self->add_symbol( PerlBean::Symbol->new( {
        symbol_name => '($VERSION)',
        assignment => $va,
        comment => "# Package version\n",
        volatile =>1,
    } ) );
EOF
        },
        {
            method_name => '_finalize_use_base',
            documented => 0,
            description => <<'EOF',
Makes the 'use base' dependency for inheritance and for Exporter stuff
EOF
            body => <<'EOF',
    my $self = shift;

    my @base = $self->get_base();
    $self->is__has_exports_() && push( @base, 'Exporter' );
    if ( scalar(@base) ) {
        my $dep = PerlBean::Dependency::Use->new( {
            dependency_name => 'base',
            import_list => [ "qw( @base )" ],
            volatile => 1,
        } );
        $self->add_dependency($dep);
    }
EOF
        },
        {
            method_name => '_mk__has_exports_',
            documented => 0,
            description => <<'EOF',
Check if symbols are exported.
EOF
            body => <<'EOF',
    my $self = shift;

    # Check all symbols
    foreach my $sym ( $self->values_symbol() ) {

        # But discard the export symbols
        if ( $sym->get_symbol_name() eq '%EXPORT_TAGS' ||
                $sym->get_symbol_name() eq '@EXPORT_OK' ||
                $sym->get_symbol_name() eq '@EXPORT' ) {
            next;
        }

        # Check if the symbol is exported
        if ( scalar( $sym->values_export_tag() ) ) {
            $self->set__has_exports_(1);
            return;
        }
    }

    # Nothing found to export
    $self->set__has_exports_(0);
EOF
        },
        {
            method_name => '_mk_value_allowed_method',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $constraints = shift;
    my $has_attributes = shift;

    # Do nothing of not attributes
    $has_attributes || return();

    my $body = ! $constraints ? "${IND}return${BFP}(1);\n" : <
${IND}my \$name${AO}=${AO}shift;

${IND}# Value is allowed if no ALLOW clauses exist for the named attribute
${IND}if${BCP}(${ACS}!${AO}exists${BFP}(${ACS}\$ALLOW_ISA{\$name}${ACS})${AO}&&${AO}!${AO}exists${BFP}(${ACS}\$ALLOW_REF{\$name}${ACS})${AO}&&${AO}!${AO}exists${BFP}(${ACS}\$ALLOW_RX{\$name}${ACS})${AO}&&${AO}!${AO}exists${BFP}(${ACS}\$ALLOW_VALUE{\$name}${ACS})${ACS})${PBOC[1]}{
${IND}${IND}return${BFP}(1);
${IND}}

${IND}# At this point, all values in \@_ must to be allowed
${IND}CHECK_VALUES:
${IND}foreach my \$val (\@_)${PBOC[1]}{
${IND}${IND}# Check ALLOW_ISA
${IND}${IND}if${BCP}(${ACS}ref${BFP}(\$val)${AO}&&${AO}exists${BFP}(${ACS}\$ALLOW_ISA{\$name}${ACS})${ACS})${PBOC[2]}{
${IND}${IND}${IND}foreach my \$class (${ACS}\@{${ACS}\$ALLOW_ISA{\$name}${ACS}}${ACS})${PBOC[3]}{
${IND}${IND}${IND}${IND}&UNIVERSAL::isa${BFP}(${ACS}\$val,${AC}\$class${ACS})${AO}&&${AO}next CHECK_VALUES;
${IND}${IND}${IND}}
${IND}${IND}}

${IND}${IND}# Check ALLOW_REF
${IND}${IND}if${BCP}(${ACS}ref${BFP}(\$val)${AO}&&${AO}exists${BFP}(${ACS}\$ALLOW_REF{\$name}${ACS})${ACS})${PBOC[2]}{
${IND}${IND}${IND}exists${BFP}(${ACS}\$ALLOW_REF{\$name}{${ACS}ref${BFP}(\$val)${ACS}}${ACS})${AO}&&${AO}next CHECK_VALUES;
${IND}${IND}}

${IND}${IND}# Check ALLOW_RX
${IND}${IND}if${BCP}(${ACS}defined${BFP}(\$val)${AO}&&${AO}!${AO}ref${BFP}(\$val)${AO}&&${AO}exists${BFP}(${ACS}\$ALLOW_RX{\$name}${ACS})${ACS})${PBOC[2]}{
${IND}${IND}${IND}foreach my \$rx (${ACS}\@{${ACS}\$ALLOW_RX{\$name}${ACS}}${ACS})${PBOC[3]}{
${IND}${IND}${IND}${IND}\$val${AO}=~${AO}/\$rx/${AO}&&${AO}next CHECK_VALUES;
${IND}${IND}${IND}}
${IND}${IND}}

${IND}${IND}# Check ALLOW_VALUE
${IND}${IND}if${BCP}(${ACS}!${AO}ref${BFP}(\$val)${AO}&&${AO}exists${BFP}(${ACS}\$ALLOW_VALUE{\$name}${ACS})${ACS})${PBOC[2]}{
${IND}${IND}${IND}exists${BFP}(${ACS}\$ALLOW_VALUE{\$name}{\$val}${ACS})${AO}&&${AO}next CHECK_VALUES;
${IND}${IND}}

${IND}${IND}# We caught a not allowed value
${IND}${IND}return${BFP}(0);
${IND}}

${IND}# OK, all values are allowed
${IND}return${BFP}(1);
EOF
    $self->add_method( PerlBean::Method->new( {
        method_name => '_value_is_allowed',
        volatile => 1,
        documented => 0,
        body => $body,
    } ) );
THE_EOF
        },
        {
            method_name => '_rm_volatile_dependencies',
            documented => 0,
            description => <<'EOF',
Remove all volatile methods from the object.
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove all dependencies that are volatile
    foreach my $dependency ( $self->values_dependency() ) {
        $dependency->is_volatile() || next;
        $self->delete_dependency( $dependency->get_dependency_name() );
    }
EOF
        },
        {
            method_name => '_rm_volatile_methods',
            documented => 0,
            description => <<'EOF',
Remove all volatile methods from the object.
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove all methods that are volatile
    foreach my $method ( $self->values_method() ) {
        $method->is_volatile() || next;
        $self->delete_method( $method->get_method_name() );
    }
EOF
        },
        {
            method_name => '_rm_volatile_symbols',
            documented => 0,
            description => <<'EOF',
Remove all volatile symbols from the object.
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove all symbols that are volatile
    foreach my $symbol ( $self->values_symbol() ) {
        $symbol->is_volatile() || next;
        $self->delete_symbol( $symbol->get_symbol_name() );
    }
EOF
        },
        {
            method_name => '_write_constructors_doc',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;
    my $eff_meth = shift;

    # Start section
    $fh->print(<
\=head1 CONSTRUCTOR

EOF

    # Do we have constructors?
    my $do_constructors = 0;
    foreach my $method ( values( %{$eff_meth} ) ) {
        $do_constructors ||= $method->isa('PerlBean::Method::Constructor');
        $do_constructors && last;
    }

    # If no constructors
    if (! $do_constructors) {
    $fh->print(<
None

EOF

        return;
    }

    $fh->print(<
\=over

EOF
    # Write constructors documentation
    foreach my $name ( sort( keys( ( %{$eff_meth} ) ) ) ) {
        my $method = $eff_meth->{$name};
        $method->isa('PerlBean::Method::Constructor') || next;
        $method->write_pod( $fh, $self->get_package() );
    }

    # Close =over
    $fh->print(<
\=back

EOF
THE_EOF
        },
        {
            method_name => '_write_declared_symbols',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    foreach my $name ( sort( $self->keys_symbol() ) ) {
        my $symbol = ( $self->values_symbol($name) )[0];

        $symbol->write($fh);
    }
THE_EOF
        },
        {
            method_name => '_write_dependencies',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    # Perl version
    my $pv = $self->get_use_perl_version();
    $fh->print("use $pv;\n");

    # Write PerlBean::Dependency::Use
    foreach my $dependency_name ( sort {&_by_pragma}
                                            ( $self->keys_dependency() ) ) {
        my $dep = ( $self->values_dependency($dependency_name) )[0];

        $dep->isa('PerlBean::Dependency::Use') || next;

        $dep->write($fh);
    }

    # Write PerlBean::Dependency::Require
    foreach my $dependency_name ( sort {&_by_pragma}
                                            ( $self->keys_dependency() ) ) {
        my $dep = ( $self->values_dependency($dependency_name) )[0];

        $dep->isa('PerlBean::Dependency::Require') || next;

        $dep->write($fh);
    }

    # Write PerlBean::Dependency::Import
    foreach my $dependency_name ( sort {&_by_pragma}
                                            ( $self->keys_dependency() ) ) {
        my $dep = ( $self->values_dependency($dependency_name) )[0];

        $dep->isa('PerlBean::Dependency::Import') || next;

        $dep->write($fh);
    }

    $fh->print("\n");
THE_EOF
        },
        {
            method_name => '_write_file_end',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    # Close the file with a '1;' only if not autoloaded
    $self->is_autoloaded() && return;

    $fh->print("1;\n");
THE_EOF
        },
        {
            method_name => '_write_doc_export',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    # Stop if no exports
    $self->is__has_exports_() || return;

    $fh->print( "=head1 EXPORT\n\n" );

    if ( ! $self->exists_export_tag_description('default') ) {
        $fh->print( "By default nothing is exported.\n\n" );
    }

    foreach my $tag ( sort( $self->keys__export_tag_() ) ) {

        $fh->print( "=head2 $tag\n\n" );

        if ( $self->exists_export_tag_description($tag) ) {
            my $tdesc = ( $self->values_export_tag_description($tag) )[0];
            $fh->print( $tdesc->get_description(), "\n" );
        } else {
            $fh->print( "TODO\n\n" );
        }

        $fh->print( "=over\n\n" );

        foreach my $name ( sort( $self->keys_symbol() ) ) {

             # Get the symbol
             my $sym = ( $self->values_symbol($name) )[0];

             # Skip if not in tag
             $sym->exists_export_tag($tag) || next;

             # Add the lines
             $fh->print( "=item $name\n\n" );

             $fh->print( $sym->get_description(), "\n" );
        }

        $fh->print( "=back\n\n" );
    }
THE_EOF
        },
        {
            method_name => '_write_doc_head',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    my $pkg = $self->get_package();
    my $sdesc = $self->get_short_description();

    my $desc = defined($self->get_description()) ?
                            $self->get_description() : "C<$pkg> TODO\n";

    my $syn = defined($self->get_synopsis()) ?
                            $self->get_synopsis() : " TODO\n";

    my $abs = defined($self->get_abstract()) ?
                            $self->get_abstract() : 'TODO';

    $fh->print( "=head1 NAME\n\n" );
    $fh->print( "${pkg} - ${sdesc}\n\n" );

    $fh->print( "=head1 SYNOPSIS\n\n" );
    $fh->print( "${syn}\n" );

    $fh->print( "=head1 ABSTRACT\n\n" );
    $fh->print( "${abs}\n\n" );

    $fh->print( "=head1 DESCRIPTION\n\n" );
    $fh->print( "${desc}\n" );
THE_EOF
        },
        {
            method_name => '_write_doc_tail',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    my $m = $MON[(localtime())[4]];
    my $y = (localtime())[5] + 1900;
    my $p = (getpwuid($>))[6];

    my $also = 'TODO';
    if (defined($self->get_collection())) {
        $also = '';
        foreach my $pkg (sort($self->get_collection()->keys_perl_bean())) {
            next if ($pkg eq $self->get_package());
            $also .= "L<$pkg>,\n";
        }
        chop($also);
        chop($also);
        $also = $also ? $also : 'NONE';
    }

    my $lic = 'TODO';
    if (defined($self->get_license())) {
        $lic = $self->get_license();
    }
    elsif (defined($self->get_collection()) && defined($self->get_collection()->get_license())) {
        $lic = $self->get_collection()->get_license();
    }

    $fh->print(<
\=head1 SEE ALSO

$also

\=head1 BUGS

None known (yet.)

\=head1 HISTORY

First development: ${m} ${y}
Last update: ${m} ${y}

\=head1 AUTHOR

${p}

\=head1 COPYRIGHT

Copyright ${y} by ${p}

\=head1 LICENSE

$lic
\=cut

EOF
THE_EOF
        },
        {
            method_name => '_write_methods_doc',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;
    my $eff_meth = shift;

    # Start section
    $fh->print(<
\=head1 METHODS

EOF

    # Do we have methods?
    my $do_methods = 0;
    foreach my $method ( values( %{$eff_meth} ) ) {
        $do_methods ||= ! $method->isa('PerlBean::Method::Constructor');
        $do_methods && last;
    }

    # If no methods
    if (! $do_methods) {
    $fh->print(<
None

EOF

        return;
    }

    $fh->print(<
\=over

EOF
    # Write constructors documentation
    foreach my $name ( sort( keys( ( %{$eff_meth} ) ) ) ) {
        my $method = $eff_meth->{$name};
        $method->isa('PerlBean::Method::Constructor') && next;
        $method->write_pod( $fh, $self->get_package() );
    }

    # Close =over
    $fh->print(<
\=back

EOF
THE_EOF
        },
        {
            method_name => '_write_package_head',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    my $pkg = $self->get_package();
    $fh->print("package $pkg;\n\n");
THE_EOF
        },
        {
            method_name => '_write_preloaded_end',
            documented => 0,
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    # End preload only for non autoloaded beans
    $self->is_autoloaded() || return;

    $fh->print(<
1;

$END

EOF
THE_EOF
        },
        {
            method_name => '_unfinalize',
            documented => 0,
            description => <<'EOF',
Un-finalize the object by:
1) removing volatile methods and symbol
2) calling set__finalized_(0)
EOF
            body => <<'EOF',
    my $self = shift;

    # Remove all volatile dependencies
    $self->_rm_volatile_dependencies();

    # Remove all volatile methods
    $self->_rm_volatile_methods();

    # Remove all volatile symbols
    $self->_rm_volatile_symbols();

    # Remember this object is not finalized
    $self->set__finalized_(0);
EOF
        },
        {
            method_name => 'write',
            parameter_description => 'FILEHANDLE',
            description => <
Write the Perl class code to C. C is an C object. On error an exception C is thrown.
EOF
            body => <<'THE_EOF',
    my $self = shift;
    my $fh = shift;

    # Finalize the package if necessary
    my $was_finalized = $self->is__finalized_();
    $self->is__finalized_() || $self->_finalize();

    # Package heading
    $self->_write_package_head($fh);

    # Dependencies
    $self->_write_dependencies($fh);

    # Declared symbols
    $self->_write_declared_symbols($fh);

    # End of preloaded methods
    $self->_write_preloaded_end($fh);

    # Start pod documentation
    $self->_write_doc_head($fh);

    # Write EXPORT documentation
    $self->_write_doc_export($fh);

    # Get all methods that are callable from this package
    $self->_get_effective_methods( \my %eff_meth );

    # Write CONSTRUCTOR documentation
    $self->_write_constructors_doc($fh, \%eff_meth);

    # Write METHODS documentation
    $self->_write_methods_doc($fh, \%eff_meth);

    # Finish pod documentation
    $self->_write_doc_tail($fh);

    # All constructor methods from this bean
    my %all_meth_ref = ();
    foreach my $name ( sort( $self->keys_method() ) ) {
        my $method = ( $self->values_method($name) )[0];
        $method->isa('PerlBean::Method::Constructor') || next;
        $method->write_code($fh);
        $all_meth_ref{$name} = $method;
    }

    # The _initialize method from this bean
    scalar( $self->values_method('_initialize') ) &&
        ( $self->values_method('_initialize') )[0]->write_code($fh);

    # All methods from this bean
    foreach my $name ( sort( $self->keys_method() ) ) {
        $name eq '_initialize' && next;
        my $method = ( $self->values_method($name) )[0];
        $method->isa('PerlBean::Method::Constructor') && next;
        $method->write_code($fh);
        $all_meth_ref{$name} = $method;
    }

    # End of file
    $self->_write_file_end($fh);

    # Un-finalize the package if necessary
    $was_finalized || $self->_unfinalize();
THE_EOF
        },
        {
            method_name => 'add_attribute',
            parameter_description => ' See add_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::add_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use add_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->add_method_factory(@_) );
EOF
        },
        {
            method_name => 'delete_attribute',
            parameter_description => ' See delete_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::delete_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use delete_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->delete_method_factory(@_) );
EOF
        },
        {
            method_name => 'exists_attribute',
            parameter_description => ' See exists_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::exists_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use exists_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->exists_method_factory(@_) );
EOF
        },
        {
            method_name => 'keys_attribute',
            parameter_description => ' See keys_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::keys_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use keys_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->keys_method_factory(@_) );
EOF
        },
        {
            method_name => 'set_attribute',
            parameter_description => ' See set_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::set_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use set_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->set_method_factory(@_) );
EOF
        },
        {
            method_name => 'values_attribute',
            parameter_description => ' See values_method_factory() ',
            description => <
Legacy method. Writes a warning to STDERR and calls C. Will be discontinued from the 4th of April 2004 on.
EOF
            body => <<'EOF',
    my $self = shift;

    $LEGACY_COUNT++;
    ( $LEGACY_COUNT < 4 ) && print STDERR "WARNING: PerlBean::values_attribute, this is a legacy support method and will be discontinued from the 4th of April 2004 on. Change your code to use values_method_factory().\nNOW!\n";
    ( $LEGACY_COUNT == 3 ) && print STDERR "Oh bother...\n";

    return( $self->values_method_factory(@_) );
EOF
        },
    ],
    sym_opt => [
        {
            symbol_name => '$LEGACY_COUNT',
            comment => <
# Legacy count variable
EOF
            assignment => "0;\n",
        },
        {
            symbol_name => '$END',
            comment => <
# Variable to not confuse AutoLoader
EOF
            assignment => "'__END__';\n",
        },
        {
            symbol_name => '@MON',
            comment => <
# Month names array
EOF
            assignment => <
qw(
${IND}January
${IND}February
${IND}March
${IND}April
${IND}May
${IND}June
${IND}July
${IND}August
${IND}September
${IND}October
${IND}November
${IND}December
);
EOF
        },
    ],
    use_opt => [
        {
            dependency_name => 'PerlBean::Method',
        },
        {
            dependency_name => 'PerlBean::Method::Constructor',
        },
        {
            dependency_name => 'PerlBean::Style',
            import_list => [ 'qw(:codegen)' ],
        },
        {
            dependency_name => 'PerlBean::Symbol',
        },
        {
            dependency_name => 'PerlBean::Dependency::Require',
        },
        {
            dependency_name => 'PerlBean::Dependency::Use',
        },
    ],
} );

sub get_syn {
    use IO::File;
    my $fh = IO::File->new('< syn-PerlBean.pl');
    $fh = IO::File->new('< gen/syn-PerlBean.pl') if (! defined($fh));
    my $syn = '';
    my $prev_line = $fh->getline ();
    while (my $line = $fh->getline ()) {
        $syn .= ' ' . $prev_line;
        $prev_line = $line;
    }
    return($syn);
}

1;