$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;

set_package()

is used to set the package name in package Circle.

add_dependency() or set_dependency()

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

set_use_perl_version()

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

push_base(), set_base() or unshift_base()

are used to express inheritance relationships. When the $pkg is written, the inheritance relationships -like Shape in this example- appear in the use base list. The Exporter bit is there because symbols are exported by package Circle.

$pkg symbols:

add_symbol() or set_symbol()

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

$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 our \%ALLOW.* symbols above are used by the generated class to check rules that apply to the $pkg's attributes. They are not exported. You could theoretically overwrite them. But don't do that!

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

The our (\$VERSION) is there to allow versioning through CVS. You could overwrite it.

Preloaded section end

 1;
 
 __END__

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

NAME section

 =head1 NAME
 
 Circle - circle shape

The package name ( which was set through set_package() ) is put in Circle -.

set_short_description()

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

ABSTRACT section

 =head1 ABSTRACT
 
 circle shape

set_abstract()

is used to set the abstract information in circle shape.

DESCRIPTION section

 =head1 DESCRIPTION
 
 circle shape

set_description()

is used to set the description information circle shape. If no description is set then C<Circle> TODO would be shown.

EXPORT section

This section describes all exported ${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

CONSTRUCTOR section

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

METHODS section

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

SEE ALSO section

 L<Rectangle>,
 L<Shape>,
 L<Square>

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

BUGS section

 None known (yet.)

This section always has None known (yet.) in it.

HISTORY section

 First development: September 2003
 Last update: September 2003

This section always has First development: C<current_date> Last update: C<current_date> in it.

AUTHOR section

 Vincenzo Zocca

This section always has the GECOS field from the passwd file.

COPYRIGHT section

 Copyright 2003 by Vincenzo Zocca

This section always contains the above message with the current_year and the GECOS field from the passwd file.

LICENSE section

 This code is licensed under B<GNU GENERAL PUBLIC LICENSE>.
 Details on L<http://gnu.org>.

This section either contains:

1) The license of the $pkg which set through method set_license()

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

3) The text TODO

Implementation section

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

End of file

 1;

If the $pkg is not autoloaded then the code above is generated in order to close the file the Perl way. The method set_autoloaded() is used to change the autoload behavior of a $pkg. NOTE: In my experience it pays to first have $pkgs preloaded and to switch to autoload after debugging.

    # 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<MATCH_METHOD> is the C<PerlBean::Method> object that must be matched in the search. C<LOOP_STOP> is used to detect loops in the inheritance. Returns a C<PerlBean::Method> if the search was successful and C<undef> 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 = <<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,
    } ) );
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<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 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 OPT_HASH_REF inherited through package $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,
    } ) );
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 => <<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 } ) ); 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" : <<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, } ) ); 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(<<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 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(<<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 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(<<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 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(<<EOF);
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 => <<EOF,
Write the Perl class code to C<FILEHANDLE>. C<FILEHANDLE> is an C<IO::Handle> object. On error an exception C<Error::Simple> 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<add_method_factory()>. 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<delete_method_factory()>. 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<exists_method_factory()>. 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<keys_method_factory()>. 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<set_method_factory()>. 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 => <<EOF,
Legacy method. Writes a warning to STDERR and calls C<values_method_factory()>. 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 => <<EOF,
# Legacy count variable
EOF
            assignment => "0;\n",
        },
        {
            symbol_name => '$END',
            comment => <<EOF,
# Variable to not confuse AutoLoader
EOF
            assignment => "'__END__';\n",
        },
        {
            symbol_name => '@MON',
            comment => <<EOF,
# Month names array
EOF
            assignment => <<EOF,
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;

cpanm PerlBean

perl -MCPAN -e shell
install PerlBean