$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