Commit fbb8ef0c authored by Sebastien Carrere's avatar Sebastien Carrere

Ajout LipmObject.pm out Authentitc.pm

parent 285c83e3
#
# $Id: LipmObject.pm 855 2012-03-13 13:35:30Z manu $
#
# Copyright INRA/CNRS
# Emmanuel.Courcelle@toulouse.inra.fr
# Jerome.Gouzy@toulouse.inra.fr
# Thomas.Faraut@toulouse.inra.fr
# This software is a computer program whose purpose is to provide a
# web-based interface for analyzing the different levels of genome
# conservations.
# This software is governed by the CeCILL license under French law and
# abiding by the rules of distribution of free software. You can use,
# modify and/ or redistribute the software under the terms of the CeCILL
# license as circulated by CEA, CNRS and INRIA at the following URL
# "http://www.cecill.info".
# As a counterpart to the access to the source code and rights to copy,
# modify and redistribute granted by the license, users are provided only
# with a limited warranty and the software's author, the holder of the
# economic rights, and the successive licensors have only limited
# liability.
# In this respect, the user's attention is drawn to the risks associated
# with loading, using, modifying and/or developing or reproducing the
# software by the user in light of its specific status of free software,
# that may mean that it is complicated to manipulate, and that also
# therefore means that it is reserved for developers and experienced
# professionals having in-depth computer knowledge. Users are therefore
# encouraged to load and test the software's suitability as regards their
# requirements in conditions enabling the security of their systems and/or
# data to be ensured and, more generally, to use and operate it in the
# same conditions as regards security.
# The fact that you are presently reading this means that you have had
# knowledge of the CeCILL license and that you accept its terms.
=head1 NAME
LipmObject - Class to define our object as hash object.
=head1 DESCRIPTION
This class defines 2 methods 'New' and 'Clone'.
All our class will be hash blessed.
If object B derives from object A, inheritance "tree" looks like:
LipmObject
^
|
|
Object_A
^
|
|
Object_B
Then, Object_A and Object_B DO NOT define any constructor,
they rather use the LipmObject New method.
However, Object_A and Object_B could define a procedure named _Init,
written as follows:
sub _Init
{
my $self = shift;
my @args = @_;
my @super_args = ...;
$self->SUPER::_Init(@super_args);
... # More initialization
}
The method Clone may be used to create a new object,
initialized from the current object.
WARNING !!! PLEASE DO NOT USE THIS METHOD if some attribute
is a ref towards some other variable or object.
=cut
package LipmObject;
use strict;
use warnings;
use General;
=head2 LipmObject::New
Title : New
Usage : The constructor
Access : Public
Function : The internal hash ($self) is created and blessed.
The protected function _Init is then called, letting the derived classes
to perform their own initialization
Args : the class, followed by object-specific arguments
Returns : The object
Globals : none
Note : The object will exist whatever happen inside _Init.
In consequence, you can have an object with no additionnal attribute.
Attributes :
__o_logger : Logger object.
=cut
sub LipmObject::New
{
my ( $class, @args ) = @_;
my $self = bless( {}, $class );
# pour info
$self->_Set( '__o_logger', undef );
# $self->{ __o_logger } = undef;
$self->_Init( @args );
return $self;
}
=head2 LipmObject::Clone
Title : Clone
Usage : Clone (=copy) the object
Access : Public
Function : A new hash is created and initialized from $self, and blessed
Args : none (-- or just the object)
Returns : The new object
Globals : none
=cut
sub LipmObject::Clone
{
my $self = shift;
my $class = ref($self);
my $new_obj = bless {%{$self}}, $class;
return $new_obj;
}
=head2 Procedure _Init
Title : _Init
Usage : $self->SUPER::_Init( -o_logger => $o_logger );
$self->SUPER::_Init( $o_logger );
Access : Protected
Procedure: if called with 1 param, set it to __o_logger
if called with an even number of params, set the -o_logger to __o_logger
Call SetLogger
Args : $o_logger, a Logger object, facultative
Globals : none
=cut
sub _Init
{
my $self = shift;
my @a_args = @_;
if ( 1 == @a_args )
{
$self->SetLogger( $a_args[0] );
}
elsif( 0 == @a_args % 2 )
{
my %h_args = @a_args;
$self->SetLogger( $h_args{ -o_logger } );
}
}
=head2 Procedure SetLogger
Title : SetLogger
Usage : $o_xx->SetLogger( $o_logger );
Prerequisite : none
Procedure : none
Args : $o_logger
=cut
sub SetLogger
{
my $self = shift;
my ( $o_logger ) = @_;
$self->_Set( '__o_logger', $o_logger );
# $self->{ __o_logger } = $o_logger;
return;
}
=head2 Procedure _Trace
Title : _Trace
Usage : $o_xx->_Trace( $o_logger );
Prerequisite : none
Procedure : none
Args : $o_logger
=cut
sub _Trace
{
my $self = shift;
my $o_logger = $self->_Get( '__o_logger' );
if( $o_logger )
{
$o_logger->Trace( @_, ref( $self ).' ' );
}
return;
}
=head2 function _GetLogger
Title : _GetLogger
Usage : $o_logger = $o_xx->_GetLogger();
Function : Accessor, returns the Logger object
Access : Protected
Returns : $o_logger
Args : none
TODO : not really useful, the public version should be used instead
=cut
sub _GetLogger
{
my $self = shift;
return $self->_Get( '__o_logger' );
}
=head2 function GetLogger
Title : GetLogger
Usage : $o_logger = $o_xx->GetLogger();
Function : Accessor, returns the Logger object
Same function as the protected version, but checks the object before returning it,
Access : Public
Returns : $o_logger
Args : none
=cut
sub GetLogger
{
my $self = shift;
return $self->_Get( '__o_logger' );
}
=head2 function _Set
Title : _Set
Usage : $self->_Set( $attribute_name => $attribute_value [, ...] );
Access : Protected
Procedure: Set the attribute $attribute_name to $attribute_value.
The aims of this function is to protect private attribute from crush in inheritance.
Args : $attribute_name, a private attribute start with '__'
$attribute_value, scalar
Globals : none
=cut
sub LipmObject::_Set
{
my $self = shift;
my %h_attr = @_;
foreach my $key ( keys %h_attr )
{
my $value = $h_attr{ $key };
if( $key =~ /^__/ )
{
my ( $mother, @a_scrap) = caller();
$key = "__$mother$key";
}
$self->{ $key } = $value;
}
return;
}
=head2 function _Get
Title : _Get
Usage : $val = $self->_Get( $attribute_name );
Access : Protected
Function : Get the attribute $attribute_name value.
The aims of this function is to protect private attribute from crush in inheritance.
Args : $attribute_name, a private attribute start with '__'
Returns : the attribute value
Globals : none
=cut
sub LipmObject::_Get
{
my $self = shift;
my @a_keys = @_;
my @a_values = ();
foreach my $key ( @a_keys )
{
if( $key =~ /^__/ )
{
my ( $mother, @a_scrap) = caller();
$key = "__$mother$key";
}
push( @a_values, $self->{ $key } );
}
return wantarray ? @a_values : $a_values[0];
}
=head2 function GetWarningHeader
Title : GetWarningHeader
Usage : warn $self -> GetWarningHeader() . "some message";
Access : Public
Function : Return a structured string useful to print in front of warning messages
The package and subroutine where the warning took place is returned
You may use this header with the object AccWarn, to classify your warnings and defer their display
Args : None
Returns : The string: WARNING Package::sub
=cut
sub GetWarningHeader
{
my $self = shift;
my ($letter) = @_;
my ($package,$file,$line,$sub) = caller(1);
my $msg = 'WARNING';
$msg .= '-' . $letter if ( defined $letter );
$msg .= " $sub called from object " . ref($self) . " -> ";
return $msg;
}
1;
__END__
=pod
=head1 COPYRIGHT NOTICE
This software is governed by the CeCILL license - www.cecill.info
=cut
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment