libropkg-perl 0.4-1.1 / usr / share / perl5 / RoPkg / Object.pm

############################################################################
##      Copyright (C) 2005 Subredu Manuel  <diablo@iasi.roedu.net>.        #
##                                                                         #
## This program is free software; you can redistribute it and/or modify    #
## it under the terms of the GNU General Public License as published by    #
## the Free Software Foundation; either version 2 of the License, or       #
## (at your option) any later version.                                     #
##                                                                         #
## This program is distributed in the hope that it will be useful,         #
## but WITHOUT ANY WARRANTY; without even the implied warranty of          #
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the           #
## GNU General Public License for more details.                            #
##                                                                         #
## You should have received a copy of the GNU General Public License       #
## along with this program; if not, write to the Free Software             #
## Foundation, Inc., 59 Temple Place - Suite 330, Boston,                  #
## MA 02111-1307,USA.                                                      #
############################################################################

package RoPkg::Object;

use strict;
use warnings;

use RoPkg::Exceptions;
use Scalar::Util qw(blessed);

use vars qw($VERSION);

$VERSION = '0.3.2';

sub _inject {
   my ($self) = @_;
   my $methods;

   #This is for backward compatibility
   if ( $self->{pf} ) {
     #rename pf into methods
     $self->{methods} = delete $self->{pf};
   }

   $methods = $self->{methods};

   foreach(keys %{$methods}) {
      my $method_name = $_;

      no strict 'refs';
      if (    $methods->{$method_name} ne '__exclude__' 
           && ! ref($self)->can($method_name)
           && $methods->{$method_name} ) {
         *{ref($self) . q{::} . $_} = sub {
                                   my ($self, $pval) = @_;

                                   if ( !blessed($self) ) {
                                     OutsideClass->throw('Called outside class instance');
                                   }

                                   if ( defined $pval) {
                                     $self->{$method_name} = $pval;
                                   }
                                   return $self->{$method_name};
                                 };
         use strict;
      }
   }

   return $self;
}

sub new {
   my ($class, %opt) = @_;
   my $self;

   $self = bless { %opt }, $class;

   return $self;
}

sub methods {
  my ($self) = @_;
  my @methods;

  if (!blessed($self)) {
    OutsideClass->throw('Called outside class instance');
  }

  foreach(sort keys %{ $self->{methods} } ) {
    next if ( ! $self->can($_) );
    push @methods, $_;
  }

  return (wantarray ? @methods : scalar @methods);
}

sub key {
  my ($self, $kvalue) = @_;

  if ( !blessed($self) ) {
    OutsideClass->throw('Called outside class instance');
  }

  foreach(keys %{ $self->{methods} } ) {
    return $_ if ( $self->{methods}->{$_} eq $kvalue );
  }

  return 0;
}

sub chkp {
  my ($self, @plist) = @_;

  if ( !blessed($self) ) {
    OutsideClass->throw('Called outside class instance');
  }

  foreach(@plist) {
    if ( !defined $self->{$_} ) {
      Param::Missing->throw($_ . ' not defined');
    }
  }

  return 0;
}

1;

__END__

=head1 NAME

 RoPkg::Object

=head1 VERSION

0.3.2

=head1 DESCRIPTION

RoPkg::Object is a general pourpose module, designed for Get/Set objects
on which you don't want to spend your time writing annoying Get/Set methods.
The primary use of the module is to be a base class.

=head1 SYNOPSIS

 package RoPkg::Person;

 use strict;
 use warnings;
 
 use RoPkg::Object;

 use base qw(RoPkg::Object);

 $pf = {
   FirstName => 'A person first name',
   LastName  => 'A person last name'
 };

 sub new {
   my ($class, %opt) = @_;
   my $self;

   $self = $class->SUPER::new(%opt);
   $self->{methods} = $pf;
   $self->_inject();

   return $self;
 }

 1;

 tester.pl
 #!/usr/bin/perl
 
 use strict;
 use warnings;

 use English qw(-no_match_vars);
 use RoPkg::Person;

 sub main {
   my $p = new RoPkg::Person();
   $p->FirstName('John');
   $p->LastName('Doe');

   print $p->FirstName,' ',$p->LastName,$RS;
 }

 main();

=head1 SUBROUTINES/METHODS

All methods (besides new()) raise OutsiteClass exception if called
outside a class instance. Each method, may raise other exceptions. Please
read the documentation of that method for aditional information.

=head2 new()

The class contructor. At this moment the constructor does nothing
(besides bless).

=head2 key($value)

Search into methods list for a entry those value is $value. Returns
the method name or 0 if such a method was not found.

=head2 methods()

In list context this method will return a list of method names. In 
scalar context returns just the number of methods. Please note that
only the valid methods are considered (tested with can($method_name)).

=head2 chkp(@plist)

Check the current object if the parameters specified in the list
are defined. If a parameter is not defined a Param::Missing
exception is raised.

=head1 SUBCLASSING

As said before, this module is specially used as a base class for those
objects with many SET/GET methods. How can you use this class in your
project ?
As seen in the SYNOPSIS, when you create the new class, in the class
constructor you call for $self->_inject method, who create (at runtime)
the new methods. The list of methods who are gonna be created is actually
a hash reference. A method can be specified like this:

 FirstName => q{-}

This means, that _inject will create a get/set method named FirstName.
There are some key values with special meaning:

=over 2

=item *) __exclude__ - the method with this value will not be created by _inject

=item *) q{} - the method with this value will not be created by _inject

=back

If a existing method is available in the class and is also included in the
list of methods who will be created by _inject, that method will be ignored
by _inject.
Each method created by _inject() has the following code:

 sub {
   my ($self, $pval) = @_;
 
   if ( !blessed($self) ) {
     OutsideClass->throw('Called outside class instance');
   }
 
   if ( defined $pval) {
     $self->{$method_name} = $pval;
   }
   return $self->{$method_name};
 };


=head1 DEPENDENCIES

RoPkg::Object require perl 5.008 or later and the Scalar::Util
module. To run the tests you also need:

=over 3

=item *) Test::More

=item *) Test::Pod

=item *) Test::Pod::Coverage

=back

=head1 DIAGNOSTICS

This module is subject of tests. To run those tests, unpack
the source and use the following command: make test

=head1 CONFIGURATION AND ENVIRONMENT

This module does not use any configuration file or environment
variables.

=head1 INCOMPATIBILITIES

None known to the author

=head1 BUGS AND LIMITATIONS

No known bugs. If you find one please send a detailed report
to me. Please note that the methods are not automatically created.
One must manual call (inside the child object) the method who
"injects" the new methods.

=head1 PERL CRITIC

This module is perl critic level 1 compliant with 2 exceptions.

=head1 AUTHOR

Subredu Manuel <diablo@iasi.roedu.net>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2005 Subredu Manuel.  All Rights Reserved.
This module is free software; you can redistribute it 
and/or modify it under the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut