PerlBean - Package to generate bean like Perl modules

 use strict;
 use PerlBean;
 use PerlBean::Attribute::Factory;

 my $bean = PerlBean->new( {
     package => 'MyPackage',
 } );
 my $factory = PerlBean::Attribute::Factory->new();
 my $attr = $factory->create_attribute( {
     method_factory_name => 'true',
     short_description => 'something is true',
 } );
 $bean->add_method_factory($attr);

 use IO::File;
 -d 'tmp' || mkdir('tmp');
 my $fh = IO::File->new('> tmp/PerlBean.pl.out');
 $bean->write($fh);

package PerlBean;

use 5.005;
use strict;
use warnings;
use AutoLoader qw(AUTOLOAD);
use Error qw(:try);
use PerlBean::Dependency::Require;
use PerlBean::Dependency::Use;
use PerlBean::Method;
use PerlBean::Method::Constructor;
use PerlBean::Style qw(:codegen);
use PerlBean::Symbol;

# Variable to not confuse AutoLoader
our $END = '__END__';

# Legacy count variable
our $LEGACY_COUNT = 0;

# Used by _value_is_allowed
our %ALLOW_ISA = (
    'collection' => [ 'PerlBean::Collection' ],
    'dependency' => [ 'PerlBean::Dependency' ],
    'export_tag_description' => [ 'PerlBean::Described::ExportTag' ],
    'method' => [ 'PerlBean::Method' ],
    'method_factory' => [ 'PerlBean::Method::Factory' ],
    'symbol' => [ 'PerlBean::Symbol' ],
);

# Used by _value_is_allowed
our %ALLOW_REF = (
);

# Used by _value_is_allowed
our %ALLOW_RX = (
    'abstract' => [ '^.*$' ],
    'base' => [ '^\S+$' ],
    'license' => [ '.*' ],
    'synopsis' => [ '.*' ],
    'use_perl_version' => [ '^v?\d+(\.[\d_]+)*' ],
);

# Used by _value_is_allowed
our %ALLOW_VALUE = (
);

# Used by _initialize
our %DEFAULT_VALUE = (
    '_finalized_' => 0,
    '_has_exports_' => 0,
    'autoloaded' => 1,
    'exception_class' => 'Error::Simple',
    'short_description' => 'NO DESCRIPTION AVAILABLE',
    'singleton' => 0,
    'use_perl_version' => $],
);

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

# Month names array
our @MON = qw(
    January
    February
    March
    April
    May
    June
    July
    August
    September
    October
    November
    December
);

1;

__END__

sub new {
    my $class = shift;

    my $self = {};
    bless( $self, ( ref($class) || $class ) );
    return( $self->_initialize(@_) );
}

sub _initialize {
    my $self = shift;
    my $opt = defined($_[0]) ? shift : {};

    # Check $opt
    ref($opt) eq 'HASH' || throw Error::Simple("ERROR: PerlBean::_initialize, first argument must be 'HASH' reference.");

    # _export_tag_, MULTI
    if ( exists( $opt->{_export_tag_} ) ) {
        ref( $opt->{_export_tag_} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option '_export_tag_' must be an 'ARRAY' reference.");
        $self->set__export_tag_( @{ $opt->{_export_tag_} } );
    }
    else {
        $self->set__export_tag_();
    }

    # _finalized_, BOOLEAN, with default value
    $self->set__finalized_( exists( $opt->{_finalized_} ) ? $opt->{_finalized_} : $DEFAULT_VALUE{_finalized_} );

    # _has_exports_, BOOLEAN, with default value
    $self->set__has_exports_( exists( $opt->{_has_exports_} ) ? $opt->{_has_exports_} : $DEFAULT_VALUE{_has_exports_} );

    # abstract, SINGLE
    exists( $opt->{abstract} ) && $self->set_abstract( $opt->{abstract} );

    # autoloaded, BOOLEAN, with default value
    $self->set_autoloaded( exists( $opt->{autoloaded} ) ? $opt->{autoloaded} : $DEFAULT_VALUE{autoloaded} );

    # base, MULTI
    if ( exists( $opt->{base} ) ) {
        ref( $opt->{base} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'base' must be an 'ARRAY' reference.");
        $self->set_base( @{ $opt->{base} } );
    }
    else {
        $self->set_base();
    }

    # collection, SINGLE
    exists( $opt->{collection} ) && $self->set_collection( $opt->{collection} );

    # dependency, MULTI, with default value
    if ( exists( $opt->{dependency} ) ) {
        ref( $opt->{dependency} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'dependency' must be an 'ARRAY' reference.");
        $self->set_dependency( @{ $opt->{dependency} } );
    }
    else {

        # Empty the dependency list
        $self->set_dependency();

        # Add 'use strict'
        $self->add_dependency( PerlBean::Dependency::Use->new( {
            dependency_name => 'strict',
        } ) );

        # Add 'use warnings'
        $self->add_dependency( PerlBean::Dependency::Use->new( {
            dependency_name => 'warnings',
        } ) );

        # Add 'use Error qw(:try)'
        $self->add_dependency( PerlBean::Dependency::Use->new( {
            dependency_name => 'Error',
            import_list => [ 'qw(:try)' ],
        } ) );

    }

    # description, SINGLE
    exists( $opt->{description} ) && $self->set_description( $opt->{description} );

    # exception_class, SINGLE, with default value
    $self->set_exception_class( exists( $opt->{exception_class} ) ? $opt->{exception_class} : $DEFAULT_VALUE{exception_class} );

    # export_tag_description, MULTI
    if ( exists( $opt->{export_tag_description} ) ) {
        ref( $opt->{export_tag_description} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'export_tag_description' must be an 'ARRAY' reference.");
        $self->set_export_tag_description( @{ $opt->{export_tag_description} } );
    }
    else {
        $self->set_export_tag_description();
    }

    # license, SINGLE
    exists( $opt->{license} ) && $self->set_license( $opt->{license} );

    # method, MULTI
    if ( exists( $opt->{method} ) ) {
        ref( $opt->{method} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'method' must be an 'ARRAY' reference.");
        $self->set_method( @{ $opt->{method} } );
    }
    else {
        $self->set_method();
    }

    # method_factory, MULTI
    if ( exists( $opt->{method_factory} ) ) {
        ref( $opt->{method_factory} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'method_factory' must be an 'ARRAY' reference.");
        $self->set_method_factory( @{ $opt->{method_factory} } );
    }
    else {
        $self->set_method_factory();
    }

    # package, SINGLE, mandatory
    exists( $opt->{package} ) || throw Error::Simple("ERROR: PerlBean::_initialize, option 'package' is mandatory.");
    $self->set_package( $opt->{package} );

    # short_description, SINGLE, with default value
    $self->set_short_description( exists( $opt->{short_description} ) ? $opt->{short_description} : $DEFAULT_VALUE{short_description} );

    # singleton, BOOLEAN, with default value
    $self->set_singleton( exists( $opt->{singleton} ) ? $opt->{singleton} : $DEFAULT_VALUE{singleton} );

    # symbol, MULTI
    if ( exists( $opt->{symbol} ) ) {
        ref( $opt->{symbol} ) eq 'ARRAY' || throw Error::Simple("ERROR: PerlBean::_initialize, specified value for option 'symbol' must be an 'ARRAY' reference.");
        $self->set_symbol( @{ $opt->{symbol} } );
    }
    else {
        $self->set_symbol();
    }

    # synopsis, SINGLE
    exists( $opt->{synopsis} ) && $self->set_synopsis( $opt->{synopsis} );

    # use_perl_version, SINGLE, with default value
    $self->set_use_perl_version( exists( $opt->{use_perl_version} ) ? $opt->{use_perl_version} : $DEFAULT_VALUE{use_perl_version} );

    # Return $self
    return($self);
}

sub _by_pragma {
    if ($a =~ /^[a-z]/ && $b !~ /^[a-z]/ ) {
        return(-1);
    }
    elsif ($a !~ /^[a-z]/ && $b =~ /^[a-z]/ ) {
        return(1);
    }
    else {
        return($a cmp $b );
    }
}

sub _finalize {
    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);
}

sub _finalize_allowed {
    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,
    } ) );
}

sub _finalize_autoload {
    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,
    } ) );
}

sub _finalize_constructor {
    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 );
}

sub _finalize_constructor_initialize {
    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 = <<EOF;
${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 .= <<EOF;
${IND}# Call the superclass' _initialize
${IND}\$self->SUPER::_initialize${BFP}(\$opt);

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

    # Code to return $self
    $body .= <<EOF;
${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,
    } ) );
}

sub _finalize_constructor_new {
    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<OPT_HASH_REF> 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<OPT_HASH_REF> is mandatory.';
            $parameter_description = 'OPT_HASH_REF';
        }

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

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

Options for C<OPT_HASH_REF> may include:

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

            # Close =over
            $desc .= <<EOF;

\=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 .= <<EOF;

Options for C<OPT_HASH_REF> inherited through package B<C<$pkg_name>> 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 .= <<EOF;

\=back
EOF
        }
    }

    # Make the body
    my $body = <<EOF;
${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,
    } ) );
}

sub _finalize_default {
    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,
    } ) );
}

sub _finalize_exports {
    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,
        } ) );
}

sub _finalize_method_factories {
    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 );
        }
    }
}

sub _finalize_singleton {
    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 => <<EOF,
Always returns the same C<${pkg}> -singleton- object instance. The first time it is called, parameters C<CONSTR_OPT> -if specified- are passed to the constructor.
EOF
                body => <<EOF,
${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
    } ) );
}

sub _finalize_use_base {
    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);
    }
}

sub _finalize_version {
    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,
    } ) );
}

sub _get_effective_attributes {
    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 );
    }
}

sub _get_effective_methods {
    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 );
    }
}

sub _get_overloaded_attribute {
    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);
}

sub _get_super_method {
    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);
}

sub _mk__has_exports_ {
    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);
}

sub _mk_value_allowed_method {
    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" : <<EOF;
${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,
    } ) );
}

sub _rm_volatile_dependencies {
    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() );
    }
}

sub _rm_volatile_methods {
    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() );
    }
}

sub _rm_volatile_symbols {
    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() );
    }
}

sub _unfinalize {
    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);
}

sub _value_is_allowed {
    my $name = shift;

    # Value is allowed if no ALLOW clauses exist for the named attribute
    if ( ! exists( $ALLOW_ISA{$name} ) && ! exists( $ALLOW_REF{$name} ) && ! exists( $ALLOW_RX{$name} ) && ! exists( $ALLOW_VALUE{$name} ) ) {
        return(1);
    }

    # At this point, all values in @_ must to be allowed
    CHECK_VALUES:
    foreach my $val (@_) {
        # Check ALLOW_ISA
        if ( ref($val) && exists( $ALLOW_ISA{$name} ) ) {
            foreach my $class ( @{ $ALLOW_ISA{$name} } ) {
                &UNIVERSAL::isa( $val, $class ) && next CHECK_VALUES;
            }
        }

        # Check ALLOW_REF
        if ( ref($val) && exists( $ALLOW_REF{$name} ) ) {
            exists( $ALLOW_REF{$name}{ ref($val) } ) && next CHECK_VALUES;
        }

        # Check ALLOW_RX
        if ( defined($val) && ! ref($val) && exists( $ALLOW_RX{$name} ) ) {
            foreach my $rx ( @{ $ALLOW_RX{$name} } ) {
                $val =~ /$rx/ && next CHECK_VALUES;
            }
        }

        # Check ALLOW_VALUE
        if ( ! ref($val) && exists( $ALLOW_VALUE{$name} ) ) {
            exists( $ALLOW_VALUE{$name}{$val} ) && next CHECK_VALUES;
        }

        # We caught a not allowed value
        return(0);
    }

    # OK, all values are allowed
    return(1);
}

sub _write_constructors_doc {
    my $self = shift;
    my $fh = shift;
    my $eff_meth = shift;

    # Start section
    $fh->print(<<EOF);
\=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(<<EOF);
None

EOF

        return;
    }

    $fh->print(<<EOF);
\=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(<<EOF);
\=back

EOF
}

sub _write_declared_symbols {
    my $self = shift;
    my $fh = shift;

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

        $symbol->write($fh);
    }
}

sub _write_dependencies {
    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");
}

sub _write_doc_export {
    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" );
    }
}

sub _write_doc_head {
    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" );
}

sub _write_doc_tail {
    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(<<EOF);
\=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
}

sub _write_file_end {
    my $self = shift;
    my $fh = shift;

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

    $fh->print("1;\n");
}

sub _write_methods_doc {
    my $self = shift;
    my $fh = shift;
    my $eff_meth = shift;

    # Start section
    $fh->print(<<EOF);
\=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(<<EOF);
None

EOF

        return;
    }

    $fh->print(<<EOF);
\=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(<<EOF);
\=back

EOF
}

sub _write_package_head {
    my $self = shift;
    my $fh = shift;

    my $pkg = $self->get_package();
    $fh->print("package $pkg;\n\n");
}

sub _write_preloaded_end {
    my $self = shift;
    my $fh = shift;

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

    $fh->print(<<EOF);
1;

$END

EOF
}

sub add__export_tag_ {
    my $self = shift;

    # Separate keys/values
    my @key = ();
    my @value = ();
    while ( my $key = shift(@_) ) {
        push( @key, $key );
        push( @value, shift(@_) );
    }

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( '_export_tag_', @value ) || throw Error::Simple("ERROR: PerlBean::add__export_tag_, one or more specified value(s) '@value' is/are not allowed.");

    # Add keys/values
    foreach my $key (@key) {
        $self->{PerlBean}{_export_tag_}{$key} = shift(@value);
    }
}

sub add_attribute {
    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(@_) );
}

sub add_dependency {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'dependency', @_ ) || throw Error::Simple("ERROR: PerlBean::add_dependency, one or more specified value(s) '@_' is/are not allowed.");

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{dependency}{ $val->get_dependency_name() } = $val;
    }
}

sub add_export_tag_description {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'export_tag_description', @_ ) || throw Error::Simple("ERROR: PerlBean::add_export_tag_description, one or more specified value(s) '@_' is/are not allowed.");

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{export_tag_description}{ $val->get_export_tag_name() } = $val;
    }
}

sub add_method {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'method', @_ ) || throw Error::Simple("ERROR: PerlBean::add_method, one or more specified value(s) '@_' is/are not allowed.");

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{method}{ $val->get_method_name() } = $val;
        $val->set_perl_bean($self);
    }
}

sub add_method_factory {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'method_factory', @_ ) || throw Error::Simple("ERROR: PerlBean::add_method_factory, one or more specified value(s) '@_' is/are not allowed.");

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{method_factory}{ $val->get_method_factory_name() } = $val;
        $val->set_perl_bean($self);
    }
}

sub add_symbol {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'symbol', @_ ) || throw Error::Simple("ERROR: PerlBean::add_symbol, one or more specified value(s) '@_' is/are not allowed.");

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{symbol}{ $val->get_symbol_name() } = $val;
    }
}

sub delete__export_tag_ {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{_export_tag_}{$val} ) || next;
        delete( $self->{PerlBean}{_export_tag_}{$val} );
        $del ++;
    }
    return($del);
}

sub delete_attribute {
    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(@_) );
}

sub delete_dependency {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{dependency}{$val} ) || next;
        delete( $self->{PerlBean}{dependency}{$val} );
        $del ++;
    }
    return($del);
}

sub delete_export_tag_description {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{export_tag_description}{$val} ) || next;
        delete( $self->{PerlBean}{export_tag_description}{$val} );
        $del ++;
    }
    return($del);
}

sub delete_method {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{method}{$val} ) || next;
        delete( $self->{PerlBean}{method}{$val} );
        $del ++;
    }
    return($del);
}

sub delete_method_factory {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{method_factory}{$val} ) || next;
        delete( $self->{PerlBean}{method_factory}{$val} );
        $del ++;
    }
    return($del);
}

sub delete_symbol {
    my $self = shift;

    # Delete values
    my $del = 0;
    foreach my $val (@_) {
        exists( $self->{PerlBean}{symbol}{$val} ) || next;
        delete( $self->{PerlBean}{symbol}{$val} );
        $del ++;
    }
    return($del);
}

sub exists__export_tag_ {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{_export_tag_}{$val} );
    }
    return($count);
}

sub exists_attribute {
    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(@_) );
}

sub exists_base {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{base}{HASH}{$val} );
    }
    return($count);
}

sub exists_dependency {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{dependency}{$val} );
    }
    return($count);
}

sub exists_export_tag_description {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{export_tag_description}{$val} );
    }
    return($count);
}

sub exists_method {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{method}{$val} );
    }
    return($count);
}

sub exists_method_factory {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{method_factory}{$val} );
    }
    return($count);
}

sub exists_symbol {
    my $self = shift;

    # Count occurrences
    my $count = 0;
    foreach my $val (@_) {
        $count += exists( $self->{PerlBean}{symbol}{$val} );
    }
    return($count);
}

sub get_abstract {
    my $self = shift;

    return( $self->{PerlBean}{abstract} );
}

sub get_base {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $i (@_) {
            push( @ret, $self->{PerlBean}{base}{ARRAY}[ int($i) ] );
        }
        return(@ret);
    }
    else {
        # Return the list
        return( @{ $self->{PerlBean}{base}{ARRAY} } );
    }
}

sub get_collection {
    my $self = shift;

    return( $self->{PerlBean}{collection} );
}

sub get_description {
    my $self = shift;

    return( $self->{PerlBean}{description} );
}

sub get_exception_class {
    my $self = shift;

    return( $self->{PerlBean}{exception_class} );
}

sub get_license {
    my $self = shift;

    return( $self->{PerlBean}{license} );
}

sub get_package {
    my $self = shift;

    return( $self->{PerlBean}{package} );
}

sub get_short_description {
    my $self = shift;

    return( $self->{PerlBean}{short_description} );
}

sub get_synopsis {
    my $self = shift;

    return( $self->{PerlBean}{synopsis} );
}

sub get_use_perl_version {
    my $self = shift;

    return( $self->{PerlBean}{use_perl_version} );
}

sub is__finalized_ {
    my $self = shift;

    if ( $self->{PerlBean}{_finalized_} ) {
        return(1);
    }
    else {
        return(0);
    }
}

sub is__has_exports_ {
    my $self = shift;

    if ( $self->{PerlBean}{_has_exports_} ) {
        return(1);
    }
    else {
        return(0);
    }
}

sub is_autoloaded {
    my $self = shift;

    if ( $self->{PerlBean}{autoloaded} ) {
        return(1);
    }
    else {
        return(0);
    }
}

sub is_singleton {
    my $self = shift;

    if ( $self->{PerlBean}{singleton} ) {
        return(1);
    }
    else {
        return(0);
    }
}

sub keys__export_tag_ {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{_export_tag_} } ) );
}

sub keys_attribute {
    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(@_) );
}

sub keys_dependency {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{dependency} } ) );
}

sub keys_export_tag_description {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{export_tag_description} } ) );
}

sub keys_method {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{method} } ) );
}

sub keys_method_factory {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{method_factory} } ) );
}

sub keys_symbol {
    my $self = shift;

    # Return all keys
    return( keys( %{ $self->{PerlBean}{symbol} } ) );
}

sub pop_base {
    my $self = shift;

    # Pop value
    my $val = pop( @{ $self->{PerlBean}{base}{ARRAY} } );
    delete( $self->{PerlBean}{base}{HASH}{$val} );
    return($val);
}

sub push_base {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'base', @_ ) || throw Error::Simple("ERROR: PerlBean::push_base, one or more specified value(s) '@_' is/are not allowed.");

    # Push values
    foreach my $val (@_) {
        next if ( exists( $self->{PerlBean}{base}{HASH}{$val} ) );
        push( @{ $self->{PerlBean}{base}{ARRAY} }, $val );
        $self->{PerlBean}{base}{HASH}{$val} = $val;
    }
}

sub set__export_tag_ {
    my $self = shift;

    # Separate keys/values
    my @key = ();
    my @value = ();
    while ( my $key = shift(@_) ) {
        push( @key, $key );
        push( @value, shift(@_) );
    }

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( '_export_tag_', @value ) || throw Error::Simple("ERROR: PerlBean::set__export_tag_, one or more specified value(s) '@value' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{_export_tag_} = {};

    # Add keys/values
    foreach my $key (@key) {
        $self->{PerlBean}{_export_tag_}{$key} = shift(@value);
    }
}

sub set__finalized_ {
    my $self = shift;

    if (shift) {
        $self->{PerlBean}{_finalized_} = 1;
    }
    else {
        $self->{PerlBean}{_finalized_} = 0;
    }
}

sub set__has_exports_ {
    my $self = shift;

    if (shift) {
        $self->{PerlBean}{_has_exports_} = 1;
    }
    else {
        $self->{PerlBean}{_has_exports_} = 0;
    }
}

sub set_abstract {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'abstract', $val ) || throw Error::Simple("ERROR: PerlBean::set_abstract, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{abstract} = $val;
}

sub set_attribute {
    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(@_) );
}

sub set_autoloaded {
    my $self = shift;

    if (shift) {
        $self->{PerlBean}{autoloaded} = 1;
    }
    else {
        $self->{PerlBean}{autoloaded} = 0;
    }
}

sub set_base {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'base', @_ ) || throw Error::Simple("ERROR: PerlBean::set_base, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{base}{ARRAY} = [];
    $self->{PerlBean}{base}{HASH} = {};

    # Push values
    foreach my $val (@_) {
        next if ( exists( $self->{PerlBean}{base}{HASH}{$val} ) );
        push( @{ $self->{PerlBean}{base}{ARRAY} }, $val );
        $self->{PerlBean}{base}{HASH}{$val} = $val;
    }
}

sub set_collection {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'collection', $val ) || throw Error::Simple("ERROR: PerlBean::set_collection, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{collection} = $val;
}

sub set_dependency {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'dependency', @_ ) || throw Error::Simple("ERROR: PerlBean::set_dependency, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{dependency} = {};

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{dependency}{ $val->get_dependency_name() } = $val;
    }
}

sub set_description {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'description', $val ) || throw Error::Simple("ERROR: PerlBean::set_description, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{description} = $val;
}

sub set_exception_class {
    my $self = shift;
    my $val = shift;

    # Value for 'exception_class' is not allowed to be empty
    defined($val) || throw Error::Simple("ERROR: PerlBean::set_exception_class, value may not be empty.");

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'exception_class', $val ) || throw Error::Simple("ERROR: PerlBean::set_exception_class, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{exception_class} = $val;
}

sub set_export_tag_description {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'export_tag_description', @_ ) || throw Error::Simple("ERROR: PerlBean::set_export_tag_description, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{export_tag_description} = {};

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{export_tag_description}{ $val->get_export_tag_name() } = $val;
    }
}

sub set_license {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'license', $val ) || throw Error::Simple("ERROR: PerlBean::set_license, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{license} = $val;
}

sub set_method {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'method', @_ ) || throw Error::Simple("ERROR: PerlBean::set_method, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{method} = {};

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{method}{ $val->get_method_name() } = $val;
        $val->set_perl_bean($self);
    }
}

sub set_method_factory {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'method_factory', @_ ) || throw Error::Simple("ERROR: PerlBean::set_method_factory, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{method_factory} = {};

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{method_factory}{ $val->get_method_factory_name() } = $val;
        $val->set_perl_bean($self);
    }
}

sub set_package {
    my $self = shift;
    my $val = shift;

    # Value for 'package' is not allowed to be empty
    defined($val) || throw Error::Simple("ERROR: PerlBean::set_package, value may not be empty.");

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'package', $val ) || throw Error::Simple("ERROR: PerlBean::set_package, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{package} = $val;
}

sub set_short_description {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'short_description', $val ) || throw Error::Simple("ERROR: PerlBean::set_short_description, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{short_description} = $val;
}

sub set_singleton {
    my $self = shift;

    if (shift) {
        $self->{PerlBean}{singleton} = 1;
    }
    else {
        $self->{PerlBean}{singleton} = 0;
    }
}

sub set_symbol {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'symbol', @_ ) || throw Error::Simple("ERROR: PerlBean::set_symbol, one or more specified value(s) '@_' is/are not allowed.");

    # Empty list
    $self->{PerlBean}{symbol} = {};

    # Add keys/values
    foreach my $val (@_) {
        $self->{PerlBean}{symbol}{ $val->get_symbol_name() } = $val;
    }
}

sub set_synopsis {
    my $self = shift;
    my $val = shift;

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'synopsis', $val ) || throw Error::Simple("ERROR: PerlBean::set_synopsis, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{synopsis} = $val;
}

sub set_use_perl_version {
    my $self = shift;
    my $val = shift;

    # Value for 'use_perl_version' is not allowed to be empty
    defined($val) || throw Error::Simple("ERROR: PerlBean::set_use_perl_version, value may not be empty.");

    # Check if isa/ref/rx/value is allowed
    &_value_is_allowed( 'use_perl_version', $val ) || throw Error::Simple("ERROR: PerlBean::set_use_perl_version, the specified value '$val' is not allowed.");

    # Assignment
    $self->{PerlBean}{use_perl_version} = $val;
}

sub shift_base {
    my $self = shift;

    # Shift value
    my $val = shift( @{ $self->{PerlBean}{base}{ARRAY} } );
    delete( $self->{PerlBean}{base}{HASH}{$val} );
    return($val);
}

sub unshift_base {
    my $self = shift;

    # Check if isas/refs/rxs/values are allowed
    &_value_is_allowed( 'base', @_ ) || throw Error::Simple("ERROR: PerlBean::unshift_base, one or more specified value(s) '@_' is/are not allowed.");

    # Unshift values
    foreach my $val ( reverse(@_) ) {
        next if ( exists( $self->{PerlBean}{base}{HASH}{$val} ) );
        unshift( @{ $self->{PerlBean}{base}{ARRAY} }, $val );
        $self->{PerlBean}{base}{HASH}{$val} = $val;
    }
}

sub values__export_tag_ {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{_export_tag_}{$key} ) && push( @ret, $self->{PerlBean}{_export_tag_}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{_export_tag_} } ) );
    }
}

sub values_attribute {
    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(@_) );
}

sub values_dependency {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{dependency}{$key} ) && push( @ret, $self->{PerlBean}{dependency}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{dependency} } ) );
    }
}

sub values_export_tag_description {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{export_tag_description}{$key} ) && push( @ret, $self->{PerlBean}{export_tag_description}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{export_tag_description} } ) );
    }
}

sub values_method {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{method}{$key} ) && push( @ret, $self->{PerlBean}{method}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{method} } ) );
    }
}

sub values_method_factory {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{method_factory}{$key} ) && push( @ret, $self->{PerlBean}{method_factory}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{method_factory} } ) );
    }
}

sub values_symbol {
    my $self = shift;

    if ( scalar(@_) ) {
        my @ret = ();
        foreach my $key (@_) {
            exists( $self->{PerlBean}{symbol}{$key} ) && push( @ret, $self->{PerlBean}{symbol}{$key} );
        }
        return(@ret);
    }
    else {
        # Return all values
        return( values( %{ $self->{PerlBean}{symbol} } ) );
    }
}

sub write {
    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();
}