File Coverage

blib/lib/Object/MultiType.pm

Criterion	Covered	Total	%
statement	125	169	73.9
branch	41	64	64.0
condition	10	12	83.3
subroutine	32	35	91.4
pod	2	2	100.0
total	210	282	74.4

#############################################################################
## Name:        MultiType.pm
## Purpose:     Object::MultiType
## Author:      Graciliano M. P.
## Modified by:
## Created:     10/05/2003
## RCS-ID:
## Copyright:   (c) 2003 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package Object::MultiType;
use 5.006 ;
use strict qw(vars) ;
our $VERSION = '0.05';

no warnings ;

 use overload (
 'bool' => '_OVER_bool' ,
 '""' => '_OVER_string' ,
 '='  => '_OVER_copy' ,
 '+'  => '_OVER_inc' ,
 '-'  => '_OVER_deinc' ,
 '0+'  => '_OVER_copy' ,
 '@{}'  => '_OVER_get_array' ,
 '%{}'  => '_OVER_get_hash' ,
 '&{}'  => '_OVER_get_code' ,
 '*{}'  => '_OVER_get_glob' ,
 'fallback' => 1 ,
 ) ;

sub is_saver { 0 ;}

#######
# NEW #
#######

sub new {
  my $class = shift ;
  my (%args) = @_ ;

  my $saver = Object::MultiType::Saver->new( $args{nodefault} ) ;
  my $this = \$saver ;
  bless($this,$class) ;

  if (!defined $args{boolsub} && defined $args{boolcode} ) { $args{boolsub} = $args{boolcode} ;}

  if ( exists $args{bool} ) { $saver->set_bool($args{bool}) ;}
  elsif ( $args{boolsub} ) {
    my $sub = $args{boolsub} ;
    $saver->set_bool(\$sub) ;
  }

  if (!defined $args{scalarsub} && defined $args{scalarcode} ) { $args{scalarsub} = $args{scalarcode} ;}

  if ( defined $args{scalar} ) { $saver->set_scalar($args{scalar}) ;}
  elsif ( $args{scalarsub} ) {
    my $sub = $args{scalarsub} ;
    $saver->set_scalar(\$sub) ;
  }

  if ( ref $args{array} eq 'ARRAY' ) { $saver->set_array($args{array}) ;}
  elsif ( $args{tiearray} ) {
    if ( $args{tieonuse} ) { $saver->{TIEONUSE}{a} = $args{tiearray} ;}
    else {
      my @array ; tie(@array,$args{tiearray},$$this) ;
      $saver->set_array(\@array) ;
    }
  }

  if    ( ref $args{hash} eq 'HASH' ) { $saver->set_hash($args{hash}) ;}
  elsif ( $args{tiehash} ) {
    if ( $args{tieonuse} ) { $saver->{TIEONUSE}{h} = $args{tiehash} ;}
    else {
      my %hash = 1 ; tie(%hash,$args{tiehash},$$this) ;
      $saver->set_hash(\%hash) ;
    }
  }

  if ( ref $args{code} eq 'CODE' ) { $saver->set_code( $args{code} ) ;}

  if ( $args{tiehandle} ) {
    if (!$args{glob}) { local(*NULL) ; $args{glob} = \*NULL ;}

    if ( $args{tieonuse} ) { $saver->{TIEONUSE}{g} = $args{tiehandle} ;}
    else { tie($args{glob} , $args{tiehandle} , $$this) ;}
  }

  if ( ref $args{glob} eq 'GLOB' ) { $saver->set_glob( $args{glob} ) ;}

  return( $this ) ;
}

##############
# _OVER_BOOL #
##############

sub _OVER_bool {
  my $this = shift ;

  if ( !exists $$this->{b} ) {
    return $this->_OVER_string ;
  }

  my $bool = $$this->bool ;

  if (ref($bool) && ref($$bool) eq 'CODE') {
    my $sub = $$bool ;
    return &$sub($this) ;
  }

  if (ref($bool) eq 'SCALAR') { return( $$bool ) ;}

  return( $bool ) ;
}

##########
# STRING #
##########

sub _OVER_string {
  my $this = shift ;
  my $scalar = $$this->scalar ;

  if (ref($$scalar) eq 'CODE') {
    my $sub = $$scalar ;
    return &$sub($this) ;
  }
  else { return( $$scalar ) ;}
}

#############
# _OVER_INC #
#############

sub _OVER_inc {
  my $this = shift ;
  my $scalar = $$this->scalar ;

  my $n ;
  if (ref($$scalar) eq 'CODE') {
    my $sub = $$scalar ;
    $n = &$sub($this) ;
  }
  else { $n = substr($$scalar , 0 ) ;}

  $n += $_[0] ;
  return $n ;
}

###############
# _OVER_DEINC #
###############

sub _OVER_deinc {
  my $this = shift ;
  my $scalar = $$this->scalar ;

  my $n ;
  if (ref($$scalar) eq 'CODE') {
    my $sub = $$scalar ;
    $n = &$sub($this) ;
  }
  else { $n = substr($$scalar , 0 ) ;}

  $n -= $_[0] ;
  return $n ;
}

##############
# _OVER_COPY #
##############

sub _OVER_copy {
  my $this = shift ;
  my $scalar = $$this->scalar ;

  if (ref($$scalar) eq 'CODE') {
    my $sub = $$scalar ;
    return &$sub($this) ;
  }
  else { return( substr($$scalar , 0 ) ) ;}
}

#############
# GET_ARRAY #
#############

sub _OVER_get_array {
  my $this = shift ;

  if ( $$this->{TIEONUSE}{a} ) {
    my @array ; tie(@array, $$this->{TIEONUSE}{a} , $$this) ;
    $$this->set_array(\@array) ;
    $$this->{TIEONUSE}{a} = undef ;
  }

  return( $$this->array ) ;
}

############
# GET_HASH #
############

sub _OVER_get_hash {
  my $this = shift ;

  if ( $$this->{TIEONUSE}{h} ) {
    my %hash = 1 ; tie(%hash, $$this->{TIEONUSE}{h} ,$$this) ;
    $$this->set_hash(\%hash) ;
    $$this->{TIEONUSE}{h} = undef ;
  }

  return( $$this->hash ) ;
}

##################
# _OVER_GET_CODE #
##################

sub _OVER_get_code {
  my $this = shift ;

  if ( !$$this->{SUBCODE} ) {
    $$this->{SUBCODE}{self} = undef ;

    my $sub = $$this->code ;
    my $ref = $$this->{SUBCODE} ;

    $$this->{SUBCODE}{sub} = sub {
      if (wantarray) {
        my @ret = &$sub( $$ref{self} , @_) ;
        $$ref{self} = undef ;
        return( @ret ) ;
      }
      else {
        my $ret = &$sub( $$ref{self} , @_) ;
        $$ref{self} = undef ;
        return( $ret ) ;
      }
    };

  }

  $$this->{SUBCODE}{self} = $this ;
  return( $$this->{SUBCODE}{sub} ) ;
}

##################
# _OVER_GET_GLOB #
##################

sub _OVER_get_glob {
  my $this = shift ;

  if ( $$this->{TIEONUSE}{g} ) {
    tie($$this->glob , $$this->{TIEONUSE}{g} , $$this) ;
    $$this->{TIEONUSE}{g} = undef ;
  }

  return( $$this->glob ) ;
}

###########
# DESTROY #
###########

sub DESTROY {
  my $this = shift ;
  $$this->clean ;
}

############################
# OBJECT::MULTITYPE::SAVER #
############################

package Object::MultiType::Saver ;

use strict qw(vars) ;

sub is_saver { 1 ;}

sub new {
  my $class = shift ;
  my ( $nodefault ) = @_ ;

  my $this ;

  if ($nodefault) { $this = {} ;}
  else {
    local(*NULL);
    $this = {
    s => \'' ,
    a => [] ,
    h => {} ,
    c => sub{} ,
    g => \*NULL ,
    } ;
  }

  bless($this,$class);
  return( $this ) ;
}

sub bool   { return( $_[0]->{b} ) ;}
sub scalar { return( $_[0]->{s} ) ;}
sub array  { return( $_[0]->{a} ) ;}
sub hash   { return( $_[0]->{h} ) ;}
sub code   { return( $_[0]->{c} ) ;}
sub glob   { return( $_[0]->{g} ) ;}

sub set_bool  { $_[0]->{b} = $_[1] ;}

sub set_scalar {
  if ($#_ == 0) { $_[0]->{s} = undef ;}
  elsif (ref($_[1]) ne 'SCALAR' && ref($_[1]) ne 'REF') { $_[0]->{s} = \$_[1] ;}
  else { $_[0]->{s} = $_[1] ;}
}

sub set_array  { $_[0]->{a} = $_[1] ;}
sub set_hash   { $_[0]->{h} = $_[1] ;}
sub set_code   { $_[0]->{c} = $_[1] ;}
sub set_glob   { $_[0]->{g} = $_[1] ;}

sub clean {
  my $this = shift ;
  $this->set_bool() ;
  $this->set_scalar() ;
  $this->set_array() ;
  $this->set_hash() ;
  $this->set_code() ;
  $this->set_glob() ;
}

sub DESTROY { &clean ;}

#######
# END #
#######

1;
__END__